lavaan coverage - 33.71%

Files
Source

# Magnus & Neudecker (1999) style matrix operations
# YR - 11 may 2011: initial version
# YR - 19 okt 2014: rename functions using lav_matrix_ prefix

# vec operator
#
# the vec operator (for 'vectorization') transforms a matrix into
# a vector by stacking the *columns* of the matrix one underneath the other
#
# M&N book: page 30
#
# note: we do not coerce to 'double/numeric' storage-mode (like as.numeric)
lav_matrix_vec <- function(A) {
  as.vector(A)
}


# vecr operator
#
# the vecr operator ransforms a matrix into
# a vector by stacking the *rows* of the matrix one underneath the other
lav_matrix_vecr <- function(A) {
  # faster way??
  # nRow <- NROW(A); nCol <- NCOL(A)
  # idx <- (seq_len(nCol) - 1L) * nRow + rep(seq_len(nRow), each = nCol)
  # if (lav_use_lavaanC() && is.numeric(A)) {
  #   return(lavaanC::m_vecr(A))
  # }
  lav_matrix_vec(t(A))
}


# vech
#
# the vech operator (for 'half vectorization') transforms a *symmetric* matrix
# into a vector by stacking the *columns* of the matrix one underneath the
# other, but eliminating all supradiagonal elements
#
# see Henderson & Searle, 1979
#
# M&N book: page 48-49
#
lav_matrix_vech <- function(S, diagonal = TRUE) {
  # if (lav_use_lavaanC() && is.numeric(S)) {
  #   return(lavaanC::m_vech(S, diagonal))
  # }
  ROW <- row(S)
  COL <- col(S)
  if (diagonal) S[ROW >= COL] else S[ROW > COL]
}


# the vechr operator transforms a *symmetric* matrix
# into a vector by stacking the *rows* of the matrix one after the
# other, but eliminating all supradiagonal elements
lav_matrix_vechr <- function(S, diagonal = TRUE) {
  # if (lav_use_lavaanC() && is.numeric(S)) {
  #   return(lavaanC::m_vechr(S, diagonal))
  # }
  S[lav_matrix_vechr_idx(n = NCOL(S), diagonal = diagonal)]
}


# the vechu operator transforms a *symmetric* matrix
# into a vector by stacking the *columns* of the matrix one after the
# other, but eliminating all infradiagonal elements
lav_matrix_vechu <- function(S, diagonal = TRUE) {
  # if (lav_use_lavaanC() && is.numeric(S)) {
  #   return(lavaanC::m_vechu(S, diagonal))
  # }
  S[lav_matrix_vechu_idx(n = NCOL(S), diagonal = diagonal)]
}

# the vechru operator transforms a *symmetric* matrix
# into a vector by stacking the *rows* of the matrix one after the
# other, but eliminating all infradiagonal elements
#
# same as vech (but using upper-diagonal elements)
lav_matrix_vechru <- function(S, diagonal = TRUE) {
  # if (lav_use_lavaanC() && is.numeric(S)) {
  #   return(lavaanC::m_vechru(S, diagonal))
  # }
  S[lav_matrix_vechru_idx(n = NCOL(S), diagonal = diagonal)]
}

# return the *vector* indices of the lower triangular elements of a
# symmetric matrix of size 'n'
lav_matrix_vech_idx <- function(n = 1L, diagonal = TRUE) {
  n <- as.integer(n)
  # if (lav_use_lavaanC() && n > 1L) {
  #   return(lavaanC::m_vech_idx(n, diagonal))
  # }
  if (n < 100L) {
    ROW <- matrix(seq_len(n), n, n)
    COL <- matrix(seq_len(n), n, n, byrow = TRUE)
    if (diagonal) which(ROW >= COL) else which(ROW > COL)
  } else {
    # ldw version
    if (diagonal) {
      unlist(lapply(
        seq_len(n),
        function(j) (j - 1L) * n + seq.int(j, n)
      ))
    } else {
      unlist(lapply(
        seq_len(n - 1L),
        function(j) (j - 1L) * n + seq.int(j + 1L, n)
      ))
    }
  }
}

# return the *row* indices of the lower triangular elements of a
# symmetric matrix of size 'n'
lav_matrix_vech_row_idx <- function(n = 1L, diagonal = TRUE) {
  n <- as.integer(n)
  # if (lav_use_lavaanC() && n > 1L) {
  #   return(lavaanC::m_vech_row_idx(n, diagonal))
  # }
  if (diagonal) {
    unlist(lapply(seq_len(n), seq.int, n))
  } else {
    1 + unlist(lapply(seq_len(n - 1), seq.int, n - 1))
  }
}

# return the *col* indices of the lower triangular elements of a
# symmetric matrix of size 'n'
lav_matrix_vech_col_idx <- function(n = 1L, diagonal = TRUE) {
  n <- as.integer(n)
  # if (lav_use_lavaanC() && n > 1L) {
  #   return(lavaanC::m_vech_col_idx(n, diagonal))
  # }
  if (!diagonal) {
    n <- n - 1L
  }
  rep.int(seq_len(n), times = rev(seq_len(n)))
}




# return the *vector* indices of the lower triangular elements of a
# symmetric matrix of size 'n' -- ROW-WISE
lav_matrix_vechr_idx <- function(n = 1L, diagonal = TRUE) {
  n <- as.integer(n)
  # if (lav_use_lavaanC() && n > 1L) {
  #   return(lavaanC::m_vechr_idx(n, diagonal))
  # }
  if (n < 100L) {
    ROW <- matrix(seq_len(n), n, n)
    COL <- matrix(seq_len(n), n, n, byrow = TRUE)
    tmp <- matrix(seq_len(n * n), n, n, byrow = TRUE)
    if (diagonal) tmp[ROW <= COL] else tmp[ROW < COL]
  } else {
    if (diagonal) {
      unlist(lapply(
        seq_len(n),
        function(j) seq.int(1, j) * n - (n - j)
      ))
    } else {
      unlist(lapply(
        seq_len(n - 1L),
        function(j) seq.int(1, j) * n - (n - j) + 1
      ))
    }
  }
}

# return the *vector* indices of the upper triangular elements of a
# symmetric matrix of size 'n' -- COLUMN-WISE
lav_matrix_vechu_idx <- function(n = 1L, diagonal = TRUE) {
  n <- as.integer(n)
  # if (lav_use_lavaanC() && n > 1L) {
  #   return(lavaanC::m_vechu_idx(n, diagonal))
  # }
  if (n < 100L) {
    ROW <- matrix(seq_len(n), n, n)
    COL <- matrix(seq_len(n), n, n, byrow = TRUE)
    if (diagonal) which(ROW <= COL) else which(ROW < COL)
  } else {
    if (diagonal) {
      unlist(lapply(seq_len(n), function(j) seq.int(j) + (j - 1) * n))
    } else {
      unlist(lapply(seq_len(n - 1L), function(j) seq.int(j) + j * n))
    }
  }
}

# return the *vector* indices of the upper triangular elements of a
# symmetric matrix of size 'n' -- ROW-WISE
lav_matrix_vechru_idx <- function(n = 1L, diagonal = TRUE) {
  n <- as.integer(n)
  # if (lav_use_lavaanC() && n > 1L) {
  #   return(lavaanC::m_vechru_idx(n, diagonal))
  # }
  if (n < 100L) {
    # FIXME!! make this more efficient (without creating 3 n*n matrices!)
    ROW <- matrix(seq_len(n), n, n)
    COL <- matrix(seq_len(n), n, n, byrow = TRUE)
    tmp <- matrix(seq_len(n * n), n, n, byrow = TRUE)
    if (diagonal) tmp[ROW >= COL] else tmp[ROW > COL]
  } else {
    # ldw version
    if (diagonal) {
      unlist(lapply(
        seq_len(n),
        function(j) seq.int(j - 1, n - 1) * n + j
      ))
    } else {
      unlist(lapply(
        seq_len(n - 1L),
        function(j) seq.int(j, n - 1) * n + j
      ))
    }
  }
}


# vech.reverse and vechru.reverse (aka `upper2full')
#
# given the output of vech(S) --or vechru(S) which is identical--
# reconstruct S
lav_matrix_vech_reverse <- lav_matrix_vechru_reverse <-
  lav_matrix_upper2full <-
  function(x, diagonal = TRUE) {
    # if (lav_use_lavaanC()) {
    #   return(lavaanC::m_vech_reverse(x, diagonal))
    # }
    # guess dimensions
    if (diagonal) {
      p <- (sqrt(1 + 8 * length(x)) - 1) / 2
    } else {
      p <- (sqrt(1 + 8 * length(x)) + 1) / 2
    }

    S <- numeric(p * p)
    S[lav_matrix_vech_idx(p, diagonal = diagonal)] <- x
    S[lav_matrix_vechru_idx(p, diagonal = diagonal)] <- x

    attr(S, "dim") <- c(p, p)
    S
  }


# vechr.reverse vechu.reversie (aka `lower2full')
#
# given the output of vechr(S) --or vechu(S) which is identical--
# reconstruct S
lav_matrix_vechr_reverse <- lav_matrix_vechu_reverse <-
  lav_matrix_lower2full <- function(x, diagonal = TRUE) {
    # if (lav_use_lavaanC()) {
    #   return(lavaanC::m_vechr_reverse(x, diagonal))
    # }
    # guess dimensions
    if (diagonal) {
      p <- (sqrt(1 + 8 * length(x)) - 1) / 2
    } else {
      p <- (sqrt(1 + 8 * length(x)) + 1) / 2
    }
    stopifnot(p == round(p, 0))

    S <- numeric(p * p)
    S[lav_matrix_vechr_idx(p, diagonal = diagonal)] <- x
    S[lav_matrix_vechu_idx(p, diagonal = diagonal)] <- x

    attr(S, "dim") <- c(p, p)
    S
  }


# return the *vector* indices of the diagonal elements of a symmetric
# matrix of size 'n'
lav_matrix_diag_idx <- function(n = 1L) {
  # if(n < 1L) return(integer(0L))
  n <- as.integer(n)
  if (n < 1L) {
    return(integer(0L))
  }
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_diag_idx(n))
  # }
  1L + (seq_len(n) - 1L) * (n + 1L)
}


# return the *vector* indices of the diagonal elements of the LOWER part
# of a symmatrix matrix of size 'n'
lav_matrix_diagh_idx <- function(n = 1L) {
  n <- as.integer(n)
  if (n < 1L) {
    return(integer(0L))
  }
  if (n == 1L) {
    return(1L)
  }
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_diagh_idx(n))
  # }
  c(1L, cumsum(n:2L) + 1L)
}


# return the *vector* indices of the ANTI diagonal elements of a symmetric
# matrix of size 'n'
lav_matrix_antidiag_idx <- function(n = 1L) {
  if (n < 1L) {
    return(integer(0L))
  }
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_antidiag_idx(n))
  # }
  1L + seq_len(n) * (n - 1L)
}

# return the *vector* indices of 'idx' elements in a vech() matrix
#
# eg if n = 4 and type == "and" and idx = c(2,4)
#    we create matrix A =
#       [,1]  [,2]  [,3]  [,4]
# [1,] FALSE FALSE FALSE FALSE
# [2,] FALSE  TRUE FALSE  TRUE
# [3,] FALSE FALSE FALSE FALSE
# [4,] FALSE  TRUE FALSE  TRUE
#
# and the result is c(5,7,10)
#
# eg if n = 4 and type == "or" and idx = c(2,4)
#    we create matrix A =
#       [,1] [,2]  [,3] [,4]
# [1,] FALSE TRUE FALSE TRUE
# [2,]  TRUE TRUE  TRUE TRUE
# [3,] FALSE TRUE FALSE TRUE
# [4,]  TRUE TRUE  TRUE TRUE
#
# and the result is c(2, 4, 5, 6, 7, 9, 10)
#
lav_matrix_vech_which_idx <- function(n = 1L, diagonal = TRUE,
                                      idx = integer(0L), type = "and",
                                      add.idx.at.start = FALSE) {
  if (length(idx) == 0L) {
    return(integer(0L))
  }
  n <- as.integer(n)
  idx <- as.integer(idx)
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_vech_which_idx(n, diagonal, idx, type, add.idx.at.start))
  # }
  A <- matrix(FALSE, n, n)
  if (type == "and") {
    A[idx, idx] <- TRUE
  } else if (type == "or") {
    A[idx, ] <- TRUE
    A[, idx] <- TRUE
  }
  pstar.idx <- which(lav_matrix_vech(A, diagonal = diagonal))

  if (add.idx.at.start) {
    pstar.idx <- c(idx, pstar.idx + n)
  }

  pstar.idx
}

# similar to lav_matrix_vech_which_idx(), but
# - only 'type = and'
# - order of idx matters!
lav_matrix_vech_match_idx <- function(n = 1L, diagonal = TRUE,
                                      idx = integer(0L)) {
  if (length(idx) == 0L) {
    return(integer(0L))
  }
  n <- as.integer(n)
  idx <- as.integer(idx)
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_vech_match_idx(n, diagonal, idx))
  # }
  pstar <- n * (n + 1) / 2
  A <- lav_matrix_vech_reverse(seq_len(pstar))
  B <- A[idx, idx, drop = FALSE]
  lav_matrix_vech(B, diagonal = diagonal)
}

# check if square matrix is diagonal (no tolerance!)
lav_matrix_is_diagonal <- function(A = NULL) {
  A <- as.matrix.default(A)
  stopifnot(nrow(A) == ncol(A))
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_is_diagonal(A))
  # }
  diag(A) <- 0
  all(A == 0)
}


# create the duplication matrix (D_n): it 'duplicates' the elements
# in vech(S) to create vec(S) (where S is symmetric)
#
# D %*% vech(S) == vec(S)
#
# M&N book: pages 48-50
#

# dup3: using col idx only
# D7 <- dup(7L); x<- apply(D7, 1, function(x) which(x > 0)); matrix(x,7,7)
lav_matrix_duplication <- function(n = 1L) {
  n <- as.integer(n)
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_duplication(n))
  # }
  if ((n < 1L) || (round(n) != n)) {
    lav_msg_stop(gettext("n must be a positive integer"))
  }

  if (n > 255L) {
    lav_msg_stop(gettext("n is too large"))
  }

  nstar <- n * (n + 1) / 2
  n2 <- n * n
  # THIS is the real bottleneck: allocating an ocean of zeroes...
  x <- numeric(n2 * nstar)

  tmp <- matrix(0L, n, n)
  tmp[lav_matrix_vech_idx(n)] <- 1:nstar
  tmp[lav_matrix_vechru_idx(n)] <- 1:nstar

  idx <- (1:n2) + (lav_matrix_vec(tmp) - 1L) * n2

  x[idx] <- 1.0

  attr(x, "dim") <- c(n2, nstar)
  x
}


# dup4: using Matrix package, returning a sparse matrix
# .dup4 <- function(n = 1L) {
#    if ((n < 1L) || (round(n) != n)) {
#        stop("n must be a positive integer")
#    }
#
#    if(n > 255L) {
#        stop("n is too large")
#    }
#
#    nstar <- n * (n+1)/2
#    #n2    <- n * n
#
#    tmp <- matrix(0L, n, n)
#    tmp[lav_matrix_vech_idx(n)] <- 1:nstar
#    tmp[lav_matrix_vechru_idx(n)] <- 1:nstar
#
#    x <- Matrix::sparseMatrix(i = 1:(n*n), j = vec(tmp), x = 1.0)
#
#    x
# }

# duplication matrix for correlation matrices:
# - it returns a matrix of size p^2 * (p*(p-1))/2
# - the columns corresponding to the diagonal elements have been removed
lav_matrix_duplication_cor <- function(n = 1L) {
  n <- as.integer(n)
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_duplication_cor(n))
  # }
  out <- lav_matrix_duplication(n = n)
  diag.idx <- lav_matrix_diagh_idx(n = n)
  out[, -diag.idx, drop = FALSE]
}

# compute t(D) %*% A (without explicitly computing D)
# sqrt(nrow(A)) is an integer
# A is not symmetric, and not even square, only n^2 ROWS
lav_matrix_duplication_pre <- function(A = matrix(0, 0, 0)) {
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_duplication_pre(A))
  # }
  # number of rows
  n2 <- NROW(A)

  # square nrow(A) only, n2 = n^2
  stopifnot(sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  # dup idx
  idx1 <- lav_matrix_vech_idx(n)
  idx2 <- lav_matrix_vechru_idx(n)

  OUT <- A[idx1, , drop = FALSE] + A[idx2, , drop = FALSE]
  u <- which(idx1 %in% idx2)
  OUT[u, ] <- OUT[u, ] / 2.0

  OUT
}

# dupr_pre is faster...
lav_matrix_duplication_dup_pre2 <- function(A = matrix(0, 0, 0)) {
  # number of rows
  n2 <- NROW(A)

  # square nrow(A) only, n2 = n^2
  stopifnot(sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  # dup idx
  idx1 <- lav_matrix_vech_idx(n)
  idx2 <- lav_matrix_vechru_idx(n)

  OUT <- A[idx1, , drop = FALSE]
  u <- which(!idx1 %in% idx2)
  OUT[u, ] <- OUT[u, ] + A[idx2[u], ]

  OUT
}

# compute t(D) %*% A (without explicitly computing D)
# sqrt(nrow(A)) is an integer
# A is not symmetric, and not even square, only n^2 ROWS
# correlation version: ignoring diagonal elements
lav_matrix_duplication_cor_pre <- function(A = matrix(0, 0, 0)) {
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_duplication_cor_pre(A))
  # }
  # number of rows
  n2 <- NROW(A)

  # square nrow(A) only, n2 = n^2
  stopifnot(sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  # dup idx
  idx1 <- lav_matrix_vech_idx(n, diagonal = FALSE)
  idx2 <- lav_matrix_vechru_idx(n, diagonal = FALSE)

  OUT <- A[idx1, , drop = FALSE] + A[idx2, , drop = FALSE]
  u <- which(idx1 %in% idx2)
  OUT[u, ] <- OUT[u, ] / 2.0

  OUT
}

# compute A %*% D (without explicitly computing D)
# sqrt(ncol(A)) must be an integer
# A is not symmetric, and not even square, only n^2 COLUMNS
lav_matrix_duplication_post <- function(A = matrix(0, 0, 0)) {
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_duplication_post(A))
  # }
  # number of columns
  n2 <- NCOL(A)

  # square A only, n2 = n^2
  stopifnot(sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  # dup idx
  idx1 <- lav_matrix_vech_idx(n)
  idx2 <- lav_matrix_vechru_idx(n)

  OUT <- A[, idx1, drop = FALSE] + A[, idx2, drop = FALSE]
  u <- which(idx1 %in% idx2)
  OUT[, u] <- OUT[, u] / 2.0

  OUT
}

# compute A %*% D (without explicitly computing D)
# sqrt(ncol(A)) must be an integer
# A is not symmetric, and not even square, only n^2 COLUMNS
# correlation version: ignoring the diagonal elements
lav_matrix_duplication_cor_post <- function(A = matrix(0, 0, 0)) {
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_duplication_cor_post(A))
  # }
  # number of columns
  n2 <- NCOL(A)

  # square A only, n2 = n^2
  stopifnot(sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  # dup idx
  idx1 <- lav_matrix_vech_idx(n, diagonal = FALSE)
  idx2 <- lav_matrix_vechru_idx(n, diagonal = FALSE)

  OUT <- A[, idx1, drop = FALSE] + A[, idx2, drop = FALSE]
  u <- which(idx1 %in% idx2)
  OUT[, u] <- OUT[, u] / 2.0

  OUT
}


# compute t(D) %*% A %*% D (without explicitly computing D)
# A must be a square matrix and sqrt(ncol) an integer
lav_matrix_duplication_pre_post <- function(A = matrix(0, 0, 0)) {
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_duplication_pre_post(A))
  # }
  # number of columns
  n2 <- NCOL(A)

  # square A only, n2 = n^2
  stopifnot(NROW(A) == n2, sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  # dup idx
  idx1 <- lav_matrix_vech_idx(n)
  idx2 <- lav_matrix_vechru_idx(n)

  OUT <- A[idx1, , drop = FALSE] + A[idx2, , drop = FALSE]
  u <- which(idx1 %in% idx2)
  OUT[u, ] <- OUT[u, ] / 2.0
  OUT <- OUT[, idx1, drop = FALSE] + OUT[, idx2, drop = FALSE]
  OUT[, u] <- OUT[, u] / 2.0

  OUT
}

# compute t(D) %*% A %*% D (without explicitly computing D)
# A must be a square matrix and sqrt(ncol) an integer
# correlation version: ignoring diagonal elements
lav_matrix_duplication_cor_pre_post <- function(A = matrix(0, 0, 0)) {
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_duplication_cor_pre_post(A))
  # }
  # number of columns
  n2 <- NCOL(A)

  # square A only, n2 = n^2
  stopifnot(NROW(A) == n2, sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  # dup idx
  idx1 <- lav_matrix_vech_idx(n, diagonal = FALSE)
  idx2 <- lav_matrix_vechru_idx(n, diagonal = FALSE)

  OUT <- A[idx1, , drop = FALSE] + A[idx2, , drop = FALSE]
  u <- which(idx1 %in% idx2)
  OUT[u, ] <- OUT[u, ] / 2.0
  OUT <- OUT[, idx1, drop = FALSE] + OUT[, idx2, drop = FALSE]
  OUT[, u] <- OUT[, u] / 2.0

  OUT
}

# create the elimination matrix L_n:
# it removes the duplicated elements in vec(A) to create vech(A)
# even if A is not symmetric
#
# L %*% vec(A) == vech(A)
lav_matrix_elimination <- function(n = 1L) {
  if ((n < 1L) || (round(n) != n)) {
    lav_msg_stop(gettext("n must be a positive integer"))
  }

  if (n > 255L) {
    lav_msg_stop(gettext("n is too large"))
  }

  nstar <- n * (n + 1) / 2
  n2 <- n * n

  # THIS is the real bottleneck: allocating an ocean of zeroes...
  L <- matrix(0, nrow = nstar, ncol = n2)
  L[ cbind(seq_len(nstar), lav_matrix_vech_idx(n)) ] <- 1

  L
}

# compute L %*% A (without explicitly computing L)
# sqrt(nrow(A)) is an integer
# A is not symmetric, and not even square, only n^2 ROWS
lav_matrix_elimination_pre <- function(A = matrix(0, 0, 0)) {
  # number of rows
  n2 <- NROW(A)

  # square nrow(A) only, n2 = n^2
  stopifnot(sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  # select vech idx rows
  idx <- lav_matrix_vech_idx(n)
  OUT <- A[idx, , drop = FALSE]

  OUT
}

# compute A  %*% t(L)(without explicitly computing L)
# sqrt(nrow(A)) is an integer
# A is not symmetric, and not even square, only n^2 COLS
lav_matrix_elimination_post <- function(A = matrix(0, 0, 0)) {
  # number of rows
  n2 <- NCOL(A)

  # square nrow(A) only, n2 = n^2
  stopifnot(sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  # select vech idx rows
  idx <- lav_matrix_vech_idx(n)
  OUT <- A[, idx, drop = FALSE]

  OUT
}

# compute L %*% A %*% t(L) (without explicitly computing L)
# A must be a square matrix and sqrt(ncol) an integer
lav_matrix_elimination_pre_post <- function(A = matrix(0, 0, 0)) {
  # number of rows
  n2 <- NCOL(A)

  # square A only, n2 = n^2
  stopifnot(NROW(A) == n2, sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  # select vech idx rows
  idx <- lav_matrix_vech_idx(n)
  OUT <- A[idx, idx, drop = FALSE]

  OUT
}





# create the generalized inverse of the duplication matrix (D^+_n):
# it removes the duplicated elements in vec(S) to create vech(S)
# if S is symmetric
#
# D^+ %*% vec(S) == vech(S)
#
# M&N book: page 49
#
# D^+ == solve(t(D_n %*% D_n) %*% t(D_n)

# create DUP.ginv without transpose
lav_matrix_duplication_ginv <- function(n = 1L) {
  # if (lav_use_lavaanC()) {
  #   n <- as.integer(n)
  #   return(lavaanC::m_duplication_ginv(n))
  # }
  if ((n < 1L) || (round(n) != n)) {
    lav_msg_stop(gettext("n must be a positive integer"))
  }

  if (n > 255L) {
    lav_msg_stop(gettext("n is too large"))
  }

  nstar <- n * (n + 1) / 2
  n2 <- n * n
  # THIS is the real bottleneck: allocating an ocean of zeroes...
  x <- numeric(nstar * n2)

  x[(lav_matrix_vech_idx(n) - 1L) * nstar + 1:nstar] <- 0.5
  x[(lav_matrix_vechru_idx(n) - 1L) * nstar + 1:nstar] <- 0.5
  x[(lav_matrix_diag_idx(n) - 1L) * nstar + lav_matrix_diagh_idx(n)] <- 1.0

  attr(x, "dim") <- c(nstar, n2)
  x
}

# pre-multiply with D^+
# number of rows in A must be 'square' (n*n)
lav_matrix_duplication_ginv_pre <- function(A = matrix(0, 0, 0)) {
  A <- as.matrix.default(A)

  # number of rows
  n2 <- NROW(A)

  # square nrow(A) only, n2 = n^2
  stopifnot(sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)
  nstar <- n * (n + 1) / 2

  idx1 <- lav_matrix_vech_idx(n)
  idx2 <- lav_matrix_vechru_idx(n)
  OUT <- (A[idx1, , drop = FALSE] + A[idx2, , drop = FALSE]) / 2
  OUT
}

# post-multiply with t(D^+)
# number of columns in A must be 'square' (n*n)
lav_matrix_duplication_ginv_post <- function(A = matrix(0, 0, 0)) {
  A <- as.matrix.default(A)

  # number of columns
  n2 <- NCOL(A)

  # square A only, n2 = n^2
  stopifnot(sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  idx1 <- lav_matrix_vech_idx(n)
  idx2 <- lav_matrix_vechru_idx(n)
  OUT <- (A[, idx1, drop = FALSE] + A[, idx2, drop = FALSE]) / 2
  OUT
}

# pre AND post-multiply with D^+: D^+ %*% A %*% t(D^+)
# for square matrices only, with ncol = nrow = n^2
lav_matrix_duplication_ginv_pre_post <- function(A = matrix(0, 0, 0)) {
  A <- as.matrix.default(A)
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_duplication_ginv_pre_post(A))
  # }
  # number of columns
  n2 <- NCOL(A)

  # square A only, n2 = n^2
  stopifnot(NROW(A) == n2, sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  idx1 <- lav_matrix_vech_idx(n)
  idx2 <- lav_matrix_vechru_idx(n)
  OUT <- (A[idx1, , drop = FALSE] + A[idx2, , drop = FALSE]) / 2
  OUT <- (OUT[, idx1, drop = FALSE] + OUT[, idx2, drop = FALSE]) / 2
  OUT
}

# pre AND post-multiply with D^+: D^+ %*% A %*% t(D^+)
# for square matrices only, with ncol = nrow = n^2
# - ignoring diagonal elements
lav_matrix_duplication_ginv_cor_pre_post <- function(A = matrix(0, 0, 0)) {
  A <- as.matrix.default(A)

  # number of columns
  n2 <- NCOL(A)

  # square A only, n2 = n^2
  stopifnot(NROW(A) == n2, sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  idx1 <- lav_matrix_vech_idx(n, diagonal = FALSE)
  idx2 <- lav_matrix_vechru_idx(n, diagonal = FALSE)
  OUT <- (A[idx1, , drop = FALSE] + A[idx2, , drop = FALSE]) / 2
  OUT <- (OUT[, idx1, drop = FALSE] + OUT[, idx2, drop = FALSE]) / 2
  OUT
}


# create the commutation matrix (K_mn)
# the mn x mx commutation matrix is a permutation matrix which
# transforms vec(A) into vec(A')
#
# K_mn %*% vec(A) == vec(A')
#
# (in Henderson & Searle 1979, it is called the vec-permutation matrix)
# M&N book: pages 46-48
#
# note: K_mn is a permutation matrix, so it is orthogonal: t(K_mn) = K_mn^-1
#       K_nm %*% K_mn == I_mn
#
# it is called the 'commutation' matrix because it enables us to interchange
# ('commute') the two matrices of a Kronecker product, eg
#   K_pm (A %x% B) K_nq == (B %x% A)
#
# important property: it allows us to transform a vec of a Kronecker product
# into the Kronecker product of the vecs (if A is m x n and B is p x q):
#   vec(A %x% B) == (I_n %x% K_qm %x% I_p)(vec A %x% vec B)

# first attempt
lav_matrix_commutation <- function(m = 1L, n = 1L) {
  # if (lav_use_lavaanC()) {
  #   m <- as.integer(m)
  #   n <- as.integer(n)
  #   return(lavaanC::m_commutation(m, n))
  # }

  if ((m < 1L) || (round(m) != m)) {
    lav_msg_stop(gettext("n must be a positive integer"))
  }

  if ((n < 1L) || (round(n) != n)) {
    lav_msg_stop(gettext("n must be a positive integer"))
  }

  p <- m * n
  x <- numeric(p * p)

  pattern <- rep(c(rep((m + 1L) * n, (m - 1L)), n + 1L), n)
  idx <- c(1L, 1L + cumsum(pattern)[-p])

  x[idx] <- 1.0
  attr(x, "dim") <- c(p, p)

  x
}

# compute K_n %*% A without explicitly computing K
# K_n = K_nn, so sqrt(nrow(A)) must be an integer!
# = permuting the rows of A
lav_matrix_commutation_pre <- function(A = matrix(0, 0, 0)) {
  A <- as.matrix(A)

  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_commutation_pre(A))
  # }

  # number of rows of A
  n2 <- nrow(A)

  # K_nn only (n2 = m * n)
  stopifnot(sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  # compute row indices
  # row.idx <- as.integer(t(matrix(1:n2, n, n)))
  row.idx <- rep(1:n, each = n) + (0:(n - 1L)) * n

  OUT <- A[row.idx, , drop = FALSE]
  OUT
}

# compute A %*% K_n without explicitly computing K
# K_n = K_nn, so sqrt(ncol(A)) must be an integer!
# = permuting the columns of A
lav_matrix_commutation_post <- function(A = matrix(0, 0, 0)) {
  A <- as.matrix(A)

  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_commutation_post(A))
  # }

  # number of columns of A
  n2 <- ncol(A)

  # K_nn only (n2 = m * n)
  stopifnot(sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  # compute col indices
  # row.idx <- as.integer(t(matrix(1:n2, n, n)))
  col.idx <- rep(1:n, each = n) + (0:(n - 1L)) * n

  OUT <- A[, col.idx, drop = FALSE]
  OUT
}

# compute K_n %*% A %*% K_n without explicitly computing K
# K_n = K_nn, so sqrt(ncol(A)) must be an integer!
# = permuting both the rows AND columns of A
lav_matrix_commutation_pre_post <- function(A = matrix(0, 0, 0)) {
  A <- as.matrix(A)
  # if (lav_use_lavaanC()) {
  #   return(lavaanC::m_commutation_pre_post(A))
  # }
  # number of columns of A
  n2 <- NCOL(A)

  # K_nn only (n2 = m * n)
  stopifnot(sqrt(n2) == round(sqrt(n2)))

  # dimension
  n <- sqrt(n2)

  # compute col indices
  row.idx <- rep(1:n, each = n) + (0:(n - 1L)) * n
  col.idx <- row.idx

  OUT <- A[row.idx, col.idx, drop = FALSE]
  OUT
}



# compute K_mn %*% A without explicitly computing K
# = permuting the rows of A
lav_matrix_commutation_mn_pre <- function(A, m = 1L, n = 1L) {
  # number of rows of A
  mn <- NROW(A)
  stopifnot(mn == m * n)

  # compute row indices
  # row.idx <- as.integer(t(matrix(1:mn, m, n)))
  row.idx <- rep(1:m, each = n) + (0:(n - 1L)) * m

  OUT <- A[row.idx, , drop = FALSE]
  OUT
}

# N_n == 1/2 (I_n^2 + K_nn)
# see MN page 48
#
# N_n == D_n %*% D^+_n
#
lav_matrix_commutation_Nn <- function(n = 1L) {
  lav_msg_stop(gettext("not implemented yet"))
}

# (simplified) kronecker product for square matrices
lav_matrix_kronecker_square <- function(A, check = TRUE) {
  dimA <- dim(A)
  n <- dimA[1L]
  n2 <- n * n
  if (check) {
    stopifnot(dimA[2L] == n)
  }

  # all possible combinations
  out <- tcrossprod(as.vector(A))

  # break up in n*n pieces, and rearrange
  dim(out) <- c(n, n, n, n)
  out <- aperm(out, perm = c(3, 1, 4, 2))

  # reshape again, to form n2 x n2 matrix
  dim(out) <- c(n2, n2)

  out
}

# (simplified) faster kronecker product for symmetric matrices
# note: not faster, but the logic extends to vech versions
lav_matrix_kronecker_symmetric <- function(S, check = TRUE) {
  dimS <- dim(S)
  n <- dimS[1L]
  n2 <- n * n
  if (check) {
    stopifnot(dimS[2L] == n)
  }

  # all possible combinations
  out <- tcrossprod(as.vector(S))

  # break up in n*(n*n) pieces, and rearrange
  dim(out) <- c(n, n * n, n)
  out <- aperm(out, perm = c(3L, 2L, 1L))

  # reshape again, to form n2 x n2 matrix
  dim(out) <- c(n2, n2)

  out
}

# shortcut for the idiom 't(S2) %*% (S %x% S) %*% S2'
# where S is symmetric, and the rows of S2 correspond to
# the elements of S
# eg - S2 = DELTA (the jacobian dS/dtheta)
lav_matrix_tS2_SxS_S2 <- function(S2, S, check = TRUE) {
  # size of S
  n <- NROW(S)

  if (check) {
    stopifnot(NROW(S2) == n * n)
  }

  A <- matrix(S %*% matrix(S2, n, ), n * n, )
  A2 <- A[rep(1:n, each = n) + (0:(n - 1L)) * n, , drop = FALSE]
  crossprod(A, A2)
}

# shortcut for the idiom 't(D) %*% (S %x% S) %*% D'
# where S is symmetric, and D is the duplication matrix
# lav_matrix_tD_SxS_D <- function(S) {

# TODO!!

# }

# square root of a positive definite symmetric matrix
lav_matrix_symmetric_sqrt <- function(S = matrix(0, 0, 0)) {
  n <- NROW(S)

  # eigen decomposition, assume symmetric matrix
  S.eigen <- eigen(S, symmetric = TRUE)
  V <- S.eigen$vectors
  d <- S.eigen$values

  # 'fix' slightly negative tiny numbers
  d[d < 0] <- 0.0

  # sqrt the eigenvalues and reconstruct
  S.sqrt <- V %*% diag(sqrt(d), n, n) %*% t(V)

  S.sqrt
}

# orthogonal complement of a matrix A
# see Satorra (1992). Sociological Methodology, 22, 249-278, footnote 3:
#
# To compute such an orthogonal matrix, consider the p* x p* matrix P = I -
# A(A'A)^-1A', which is idempotent of rank p* - q. Consider the singular value
# decomposition P = HVH', where H is a p* x (p* - q) matrix of full column rank,
# and V is a (p* - q) x (p* - q) diagonal matrix. It is obvious that H'A = 0;
# hence, H is the desired orthogonal complement. This method of constructing an
# orthogonal complement was proposed by Heinz Neudecker (1990, pers. comm.).
#
# update YR 21 okt 2014:
# - note that A %*% solve(t(A) %*% A) %*% t(A) == tcrossprod(qr.Q(qr(A)))
# - if we are using qr, we can as well use qr.Q to get the complement
#
lav_matrix_orthogonal_complement <- function(A = matrix(0, 0, 0)) {
  QR <- qr(A)
  ranK <- QR$rank

  # following Heinz Neudecker:
  # n <- nrow(A)
  # P <- diag(n) - tcrossprod(qr.Q(QR))
  # OUT <- svd(P)$u[, seq_len(n - ranK), drop = FALSE]

  Q <- qr.Q(QR, complete = TRUE)
  # get rid of the first ranK columns
  OUT <- Q[, -seq_len(ranK), drop = FALSE]

  OUT
}

# construct block diagonal matrix from a list of matrices
# ... can contain multiple arguments, which will be coerced to a list
#     or it can be a single list (of matrices)
lav_matrix_bdiag <- function(...) {
  if (nargs() == 0L) {
    return(matrix(0, 0, 0))
  }
  dots <- list(...)

  # create list of matrices
  if (is.list(dots[[1]])) {
    mlist <- dots[[1]]
  } else {
    mlist <- dots
  }
  if (length(mlist) == 1L) {
    return(mlist[[1]])
  }

  # more than 1 matrix
  nmat <- length(mlist)
  nrows <- sapply(mlist, NROW)
  crows <- cumsum(nrows)
  ncols <- sapply(mlist, NCOL)
  ccols <- cumsum(ncols)
  trows <- sum(nrows)
  tcols <- sum(ncols)
  # empty names will shorten the c/r-names vector
  cnames  <- unlist(lapply(mlist, colnames))
  rnames  <- unlist(lapply(mlist, rownames))

  x <- numeric(trows * tcols)

  for (m in seq_len(nmat)) {
    if (m > 1L) {
      rcoffset <- trows * ccols[m - 1] + crows[m - 1]
    } else {
      rcoffset <- 0L
    }
    m.idx <- (rep((0:(ncols[m] - 1L)) * trows, each = nrows[m]) +
      rep(1:nrows[m], ncols[m]) + rcoffset)
    x[m.idx] <- mlist[[m]]
  }

  attr(x, "dim") <- c(trows, tcols)
  # col/row names (only if complete)
  if (nrow(x) == length(rnames) && ncol(x) == length(cnames)) {
    attr(x, "dimnames") <- list(rnames, cnames)
  }

  x
}

# trace of a single square matrix, or the trace of a product of (compatible)
# matrices resulting in a single square matrix
lav_matrix_trace <- function(..., check = TRUE) {
  if (nargs() == 0L) {
    return(as.numeric(NA))
  }
  dots <- list(...)

  # create list of matrices
  if (is.list(dots[[1]])) {
    mlist <- dots[[1]]
  } else {
    mlist <- dots
  }

  # number of matrices
  nMat <- length(mlist)

  # single matrix
  if (nMat == 1L) {
    S <- mlist[[1]]
    if (check) {
      # check if square
      stopifnot(NROW(S) == NCOL(S))
    }
    out <- sum(S[lav_matrix_diag_idx(n = NROW(S))])
  } else if (nMat == 2L) {
    # dimension check is done by '*'
    out <- sum(mlist[[1]] * t(mlist[[2]]))
  } else if (nMat == 3L) {
    A <- mlist[[1]]
    B <- mlist[[2]]
    C <- mlist[[3]]

    # A, B, C
    # below is the logic; to be coded inline
    # DIAG <- numeric( NROW(A) )
    # for(i in seq_len(NROW(A))) {
    #     DIAG[i] <- sum( rep(A[i,], times = NCOL(B)) *
    #                  as.vector(B) *
    #                  rep(C[,i], each=NROW(B)) )
    # }
    # out <- sum(DIAG)

    # FIXME:

    # dimension check is automatic
    B2 <- B %*% C
    out <- sum(A * t(B2))
  } else {
    # nRows <- sapply(mlist, NROW)
    # nCols <- sapply(mlist, NCOL)

    # check if product is ok
    # stopifnot(all(nCols[seq_len(nMat-1L)] == nRows[2:nMat]))

    # check if product is square
    # stopifnot(nRows[1] == nCols[nMat])

    M1 <- mlist[[1]]
    M2 <- mlist[[2]]
    for (m in 3L:nMat) {
      M2 <- M2 %*% mlist[[m]]
    }
    out <- sum(M1 * t(M2))
  }

  out
}

# crossproduct, but handling NAs pairwise, if needed
# otherwise, just call base::crossprod
lav_matrix_crossprod <- function(A, B) {
  # single argument?
  if (missing(B)) {
    if (!anyNA(A)) {
      return(base::crossprod(A))
    }
    B <- A
    # no missings?
  } else if (!anyNA(A) && !anyNA(B)) {
    return(base::crossprod(A, B))
  }

  # A and B must be matrices
  if (!inherits(A, "matrix")) {
    A <- matrix(A)
  }
  if (!inherits(B, "matrix")) {
    B <- matrix(B)
  }

  out <- apply(B, 2L, function(x) colSums(A * x, na.rm = TRUE))

  # only when A is a vector, and B is a matrix, we get back a vector
  # while the result should be a matrix with 1-row
  if (!is.matrix(out)) {
    out <- t(matrix(out))
  }

  out
}


# reduced row echelon form of A
lav_matrix_rref <- function(A, tol = sqrt(.Machine$double.eps)) {
  # MATLAB documentation says rref uses: tol = (max(size(A))*eps *norm(A,inf)
  if (missing(tol)) {
    A.norm <- max(abs(apply(A, 1, sum)))
    tol <- max(dim(A)) * A.norm * .Machine$double.eps
  }

  # check if A is a matrix
  stopifnot(is.matrix(A))

  # dimensions
  nRow <- NROW(A)
  nCol <- NCOL(A)
  pivot <- integer(0L)

  # catch empty matrix
  if (nRow == 0 && nCol == 0) {
    return(matrix(0, 0, 0))
  }

  rowIndex <- colIndex <- 1
  while (rowIndex <= nRow &&
    colIndex <= nCol) {
    # look for largest (in absolute value) element in this column:
    i.below <- which.max(abs(A[rowIndex:nRow, colIndex]))
    i <- i.below + rowIndex - 1L
    p <- A[i, colIndex]

    # check if column is empty
    if (abs(p) <= tol) {
      A[rowIndex:nRow, colIndex] <- 0L # clean up
      colIndex <- colIndex + 1
    } else {
      # store pivot column
      pivot <- c(pivot, colIndex)

      # do we need to swap column?
      if (rowIndex != i) {
        A[c(rowIndex, i), colIndex:nCol] <-
          A[c(i, rowIndex), colIndex:nCol]
      }

      # scale pivot to be 1.0
      A[rowIndex, colIndex:nCol] <- A[rowIndex, colIndex:nCol] / p

      # create zeroes below and above pivot
      other <- seq_len(nRow)[-rowIndex]
      A[other, colIndex:nCol] <-
        A[other, colIndex:nCol] - tcrossprod(
          A[other, colIndex],
          A[rowIndex, colIndex:nCol]
        )
      # next row/col
      rowIndex <- rowIndex + 1
      colIndex <- colIndex + 1
    }
  }

  # rounding?

  list(R = A, pivot = pivot)
}

# non-orthonoramal (left) null space basis, using rref
lav_matrix_orthogonal_complement2 <- function(
    A,
    tol = sqrt(.Machine$double.eps)) {
  # left
  A <- t(A)

  # compute rref
  out <- lav_matrix_rref(A = A, tol = tol)

  # number of free columns in R (if any)
  nfree <- NCOL(A) - length(out$pivot)

  if (nfree) {
    R <- out$R

    # remove all-zero rows
    zero.idx <- which(apply(R, 1, function(x) {
      all(abs(x) < tol)
    }))
    if (length(zero.idx) > 0) {
      R <- R[-zero.idx, , drop = FALSE]
    }

    FREE <- R[, -out$pivot, drop = FALSE]
    I <- diag(nfree)
    N <- rbind(-FREE, I)
  } else {
    N <- matrix(0, nrow = NCOL(A), ncol = 0L)
  }

  N
}


# inverse of a non-singular (not necessarily positive-definite) symmetric matrix
# FIXME: error handling?
lav_matrix_symmetric_inverse <- function(S, logdet = FALSE,
                                         Sinv.method = "eigen",
                                         zero.warn = FALSE) {
  # catch zero cols/rows
  zero.idx <- which(colSums(S) == 0 & diag(S) == 0 & rowSums(S) == 0)
  S.orig <- S
  if (length(zero.idx) > 0L) {
    if (zero.warn) {
      lav_msg_warn(gettext("matrix to be inverted contains zero cols/rows"))
    }
    S <- S[-zero.idx, -zero.idx, drop = FALSE]
  }

  P <- NCOL(S)

  if (P == 0L) {
    S.inv <- matrix(0, 0, 0)
    if (logdet) {
      attr(S.inv, "logdet") <- 0
    }
    return(S.inv)
  } else if (P == 1L) {
    tmp <- S[1, 1]
    S.inv <- matrix(1 / tmp, 1, 1)
    if (logdet) {
      if (tmp > 0) {
        attr(S.inv, "logdet") <- log(tmp)
      } else {
        attr(S.inv, "logdet") <- -Inf
      }
    }
  } else if (P == 2L) {
    a11 <- S[1, 1]
    a12 <- S[1, 2]
    a21 <- S[2, 1]
    a22 <- S[2, 2]
    tmp <- a11 * a22 - a12 * a21
    if (tmp == 0) {
      S.inv <- matrix(c(Inf, Inf, Inf, Inf), 2, 2)
      if (logdet) {
        attr(S.inv, "logdet") <- -Inf
      }
    } else {
      S.inv <- matrix(c(a22 / tmp, -a21 / tmp, -a12 / tmp, a11 / tmp), 2, 2)
      if (logdet) {
        if (tmp > 0) {
          attr(S.inv, "logdet") <- log(tmp)
        } else {
          attr(S.inv, "logdet") <- -Inf
        }
      }
    }
  } else if (Sinv.method == "eigen") {
    EV <- eigen(S, symmetric = TRUE)
    # V %*% diag(1/d) %*% V^{-1}, where V^{-1} = V^T
    S.inv <-
      tcrossprod(
        EV$vectors / rep(EV$values, each = length(EV$values)),
        EV$vectors
      )

    # 0.5 version
    # S.inv <- tcrossprod(sweep(EV$vectors, 2L,
    #                          STATS = (1/EV$values), FUN="*"), EV$vectors)

    if (logdet) {
      if (all(EV$values >= 0)) {
        attr(S.inv, "logdet") <- sum(log(EV$values))
      } else {
        attr(S.inv, "logdet") <- as.numeric(NA)
      }
    }
  } else if (Sinv.method == "solve") {
    S.inv <- solve.default(S)
    if (logdet) {
      ev <- eigen(S, symmetric = TRUE, only.values = TRUE)
      if (all(ev$values >= 0)) {
        attr(S.inv, "logdet") <- sum(log(ev$values))
      } else {
        attr(S.inv, "logdet") <- as.numeric(NA)
      }
    }
  } else if (Sinv.method == "chol") {
    # this will break if S is not positive definite
    cS <- chol.default(S)
    S.inv <- chol2inv(cS)
    if (logdet) {
      diag.cS <- diag(cS)
      attr(S.inv, "logdet") <- sum(log(diag.cS * diag.cS))
    }
  } else {
    lav_msg_stop(gettext("method must be either `eigen', `solve' or `chol'"))
  }

  if (length(zero.idx) > 0L) {
    logdet <- attr(S.inv, "logdet")
    tmp <- S.orig
    tmp[-zero.idx, -zero.idx] <- S.inv
    S.inv <- tmp
    attr(S.inv, "logdet") <- logdet
    attr(S.inv, "zero.idx") <- zero.idx
  }

  S.inv
}

# update inverse of A, after removing 1 or more rows (and corresponding
# colums) from A
#
# - this is just an application of the inverse of partitioned matrices
# - only removal for now
#
lav_matrix_inverse_update <- function(A.inv, rm.idx = integer(0L)) {
  ndel <- length(rm.idx)

  # rank-1 update
  if (ndel == 1L) {
    a <- A.inv[-rm.idx, rm.idx, drop = FALSE]
    b <- A.inv[rm.idx, -rm.idx, drop = FALSE]
    h <- A.inv[rm.idx, rm.idx]
    out <- A.inv[-rm.idx, -rm.idx, drop = FALSE] - (a %*% b) / h
  }

  # rank-n update
  else if (ndel < NCOL(A.inv)) {
    A <- A.inv[-rm.idx, rm.idx, drop = FALSE]
    B <- A.inv[rm.idx, -rm.idx, drop = FALSE]
    H <- A.inv[rm.idx, rm.idx, drop = FALSE]
    out <- A.inv[-rm.idx, -rm.idx, drop = FALSE] - A %*% solve.default(H, B)

    # erase all col/rows...
  } else if (ndel == NCOL(A.inv)) {
    out <- matrix(0, 0, 0)
  }

  out
}

# update inverse of S, after removing 1 or more rows (and corresponding
# colums) from S, a symmetric matrix
#
# - only removal for now!
#
lav_matrix_symmetric_inverse_update <- function(S.inv, rm.idx = integer(0L),
                                                logdet = FALSE,
                                                S.logdet = NULL) {
  ndel <- length(rm.idx)

  if (ndel == 0L) {
    out <- S.inv
    if (logdet) {
      attr(out, "logdet") <- S.logdet
    }
  }

  # rank-1 update
  else if (ndel == 1L) {
    h <- S.inv[rm.idx, rm.idx]
    a <- S.inv[-rm.idx, rm.idx, drop = FALSE] / sqrt(h)
    out <- S.inv[-rm.idx, -rm.idx, drop = FALSE] - tcrossprod(a)
    if (logdet) {
      attr(out, "logdet") <- S.logdet + log(h)
    }
  }

  # rank-n update
  else if (ndel < NCOL(S.inv)) {
    A <- S.inv[rm.idx, -rm.idx, drop = FALSE]
    H <- S.inv[rm.idx, rm.idx, drop = FALSE]
    out <- (S.inv[-rm.idx, -rm.idx, drop = FALSE] -
      crossprod(A, solve.default(H, A)))
    if (logdet) {
      # cH <- chol.default(Re(H)); diag.cH <- diag(cH)
      # H.logdet <- sum(log(diag.cH * diag.cH))
      H.logdet <- log(det(H))
      attr(out, "logdet") <- S.logdet + H.logdet
    }

    # erase all col/rows...
  } else if (ndel == NCOL(S.inv)) {
    out <- matrix(0, 0, 0)
  } else {
    lav_msg_stop(gettext("column indices exceed number of columns in S.inv"))
  }

  out
}


# update determinant of A, after removing 1 or more rows (and corresponding
# colums) from A
#
lav_matrix_det_update <- function(det.A, A.inv, rm.idx = integer(0L)) {
  ndel <- length(rm.idx)

  # rank-1 update
  if (ndel == 1L) {
    h <- A.inv[rm.idx, rm.idx]
    out <- det.A * h
  }

  # rank-n update
  else if (ndel < NCOL(A.inv)) {
    H <- A.inv[rm.idx, rm.idx, drop = FALSE]
    det.H <- det(H)
    out <- det.A * det.H

    # erase all col/rows...
  } else if (ndel == NCOL(A.inv)) {
    out <- matrix(0, 0, 0)
  }

  out
}

# update determinant of S, after removing 1 or more rows (and corresponding
# colums) from S, a symmetric matrix
#
lav_matrix_symmetric_det_update <- function(det.S, S.inv, rm.idx = integer(0L)) {
  ndel <- length(rm.idx)

  # rank-1 update
  if (ndel == 1L) {
    h <- S.inv[rm.idx, rm.idx]
    out <- det.S * h
  }

  # rank-n update
  else if (ndel < NCOL(S.inv)) {
    H <- S.inv[rm.idx, rm.idx, drop = FALSE]
    cH <- chol.default(H)
    diag.cH <- diag(cH)
    det.H <- prod(diag.cH * diag.cH)
    out <- det.S * det.H

    # erase all col/rows...
  } else if (ndel == NCOL(S.inv)) {
    out <- numeric(0L)
  }

  out
}

# update log determinant of S, after removing 1 or more rows (and corresponding
# colums) from S, a symmetric matrix
#
lav_matrix_symmetric_logdet_update <- function(S.logdet, S.inv,
                                               rm.idx = integer(0L)) {
  ndel <- length(rm.idx)

  # rank-1 update
  if (ndel == 1L) {
    h <- S.inv[rm.idx, rm.idx]
    out <- S.logdet + log(h)
  }

  # rank-n update
  else if (ndel < NCOL(S.inv)) {
    H <- S.inv[rm.idx, rm.idx, drop = FALSE]
    cH <- chol.default(H)
    diag.cH <- diag(cH)
    H.logdet <- sum(log(diag.cH * diag.cH))
    out <- S.logdet + H.logdet

    # erase all col/rows...
  } else if (ndel == NCOL(S.inv)) {
    out <- numeric(0L)
  }

  out
}

# compute `lambda': the smallest root of the determinantal equation
# |M - lambda*P| = 0 (see Fuller 1987, p.125 or p.172
#
# the function allows for zero rows/columns in P, by regressing them out
# this approach was suggested to me by Wayne A. Fuller, personal communication,
# 12 Nov 2020
#
lav_matrix_symmetric_diff_smallest_root <- function(M = NULL, P = NULL) {
  # check input (we will 'assume' they are square and symmetric)
  stopifnot(is.matrix(M), is.matrix(P))

  # check if P is diagonal or not
  PdiagFlag <- FALSE
  tmp <- P
  diag(tmp) <- 0
  if (all(abs(tmp) < sqrt(.Machine$double.eps))) {
    PdiagFlag <- TRUE
  }

  # diagonal elements of P
  nP <- nrow(P)
  diagP <- P[lav_matrix_diag_idx(nP)]

  # force diagonal elements of P to be nonnegative (warn?)
  neg.idx <- which(diagP < 0)
  if (length(neg.idx) > 0L) {
    lav_msg_warn(gettext(
      "some diagonal elements of P are negative (and set to zero)"))
    diag(P)[neg.idx] <- diagP[neg.idx] <- 0
  }

  # check for (near)zero diagonal elements
  zero.idx <- which(abs(diagP) < sqrt(.Machine$double.eps))

  # three cases:
  #    1. all elements are zero (P=0) -> lambda = 0
  #    2. no elements are zero
  #    3. some elements are zero -> regress out

  # 1. all elements are zero
  if (length(zero.idx) == nP) {
    return(0.0)
  }

  # 2. no elements are zero
  else if (length(zero.idx) == 0L) {
    if (PdiagFlag) {
      Ldiag <- 1 / sqrt(diagP)
      LML <- t(Ldiag * M) * Ldiag
    } else {
      L <- solve(lav_matrix_symmetric_sqrt(P))
      LML <- L %*% M %*% t(L)
    }

    # compute lambda
    lambda <- eigen(LML, symmetric = TRUE, only.values = TRUE)$values[nP]

    # 3. some elements are zero
  } else {
    # regress out M-block corresponding to zero diagonal elements in P

    # partition M accordingly: p = positive, n = negative
    M.pp <- M[-zero.idx, -zero.idx, drop = FALSE]
    M.pn <- M[-zero.idx, zero.idx, drop = FALSE]
    M.np <- M[zero.idx, -zero.idx, drop = FALSE]
    M.nn <- M[zero.idx, zero.idx, drop = FALSE]

    # create Mp.n
    Mp.n <- M.pp - M.pn %*% solve(M.nn) %*% M.np

    # extract positive part of P
    P.p <- P[-zero.idx, -zero.idx, drop = FALSE]

    # compute smallest root
    if (PdiagFlag) {
      diagPp <- diag(P.p)
      Ldiag <- 1 / sqrt(diagPp)
      LML <- t(Ldiag * Mp.n) * Ldiag
    } else {
      L <- solve(lav_matrix_symmetric_sqrt(P.p))
      LML <- L %*% Mp.n %*% t(L)
    }
    lambda <- eigen(LML,
      symmetric = TRUE,
      only.values = TRUE
    )$values[nrow(P.p)]
  }

  lambda
}

# force a symmetric matrix to be positive definite
# simple textbook version (see Matrix::nearPD for a more sophisticated version)
#
lav_matrix_symmetric_force_pd <- function(S, tol = 1e-06) {
  if (ncol(S) == 1L) {
    return(matrix(max(S[1, 1], tol), 1L, 1L))
  }

  # eigen decomposition
  S.eigen <- eigen(S, symmetric = TRUE)

  # eigen values
  ev <- S.eigen$values

  # replace small/negative eigen values
  ev[ev / abs(ev[1]) < tol] <- tol * abs(ev[1])

  # reconstruct
  out <- S.eigen$vectors %*% diag(ev) %*% t(S.eigen$vectors)

  out
}

# compute sample covariance matrix, divided by 'N' (not N-1, as in cov)
#
# Mu is not supposed to be ybar, but close
# if provided, we compute S as 1/N*crossprod(Y - Mu) instead of
#                              1/N*crossprod(Y - ybar)
lav_matrix_cov <- function(Y, Mu = NULL) {
  N <- NROW(Y)
  S1 <- stats::cov(Y) # uses a corrected two-pass algorithm
  S <- S1 * (N - 1) / N

  # Mu?
  if (!is.null(Mu)) {
    P <- NCOL(Y)
    ybar <- base::.colMeans(Y, m = N, n = P)
    S <- S + tcrossprod(ybar - Mu)
  }

  S
}

# transform a matrix to match a given target mean/covariance
lav_matrix_transform_mean_cov <- function(Y,
                                          target.mean = numeric(NCOL(Y)),
                                          target.cov = diag(NCOL(Y))) {
  # coerce to matrix
  Y <- as.matrix.default(Y)

  # convert to vector
  target.mean <- as.vector(target.mean)

  S <- lav_matrix_cov(Y)
  S.inv <- solve.default(S)
  S.inv.sqrt <- lav_matrix_symmetric_sqrt(S.inv)
  target.cov.sqrt <- lav_matrix_symmetric_sqrt(target.cov)

  # transform cov
  X <- Y %*% S.inv.sqrt %*% target.cov.sqrt

  # shift mean
  xbar <- colMeans(X)
  X <- t(t(X) - xbar + target.mean)

  X
}

# weighted column means
#
# for each column in Y: mean = sum(wt * Y)/sum(wt)
#
# if we have missing values, we use only the observations and weights
# that are NOT missing
#
lav_matrix_mean_wt <- function(Y, wt = NULL) {
  Y <- unname(as.matrix.default(Y))
  DIM <- dim(Y)

  if (is.null(wt)) {
    return(colMeans(Y, na.rm = TRUE))
  }

  if (anyNA(Y)) {
    WT <- wt * !is.na(Y)
    wN <- .colSums(WT, m = DIM[1], n = DIM[2])
    out <- .colSums(wt * Y, m = DIM[1], n = DIM[2], na.rm = TRUE) / wN
  } else {
    out <- .colSums(wt * Y, m = DIM[1], n = DIM[2]) / sum(wt)
  }

  out
}

# weighted column variances
#
# for each column in Y: var = sum(wt * (Y - w.mean(Y))^2) / N
#
# where N = sum(wt) - 1 (method = "unbiased") assuming wt are frequency weights
#   or  N = sum(wt)     (method = "ML")
#
# Note: another approach (when the weights are 'reliability weights' is to
#       use N = sum(wt) - sum(wt^2)/sum(wt) (not implemented here)
#
# if we have missing values, we use only the observations and weights
# that are NOT missing
#
lav_matrix_var_wt <- function(Y, wt = NULL, method = c("unbiased", "ML")) {
  Y <- unname(as.matrix.default(Y))
  DIM <- dim(Y)

  if (is.null(wt)) {
    wt <- rep(1, nrow(Y))
  }

  if (anyNA(Y)) {
    WT <- wt * !is.na(Y)
    wN <- .colSums(WT, m = DIM[1], n = DIM[2])
    w.mean <- .colSums(wt * Y, m = DIM[1], n = DIM[2], na.rm = TRUE) / wN
    Ytc <- t(t(Y) - w.mean)
    tmp <- .colSums(wt * Ytc * Ytc, m = DIM[1], n = DIM[2], na.rm = TRUE)
    out <- switch(match.arg(method),
      unbiased = tmp / (wN - 1),
      ML = tmp / wN
    )
  } else {
    w.mean <- .colSums(wt * Y, m = DIM[1], n = DIM[2]) / sum(wt)
    Ytc <- t(t(Y) - w.mean)
    tmp <- .colSums(wt * Ytc * Ytc, m = DIM[1], n = DIM[2])
    out <- switch(match.arg(method),
      unbiased = tmp / (sum(wt) - 1),
      ML = tmp / sum(wt)
    )
  }

  out
}

# weighted variance-covariance matrix
#
# always dividing by sum(wt) (for now) (=ML version)
#
# if we have missing values, we use only the observations and weights
# that are NOT missing
#
# same as cov.wt(Y, wt, method = "ML")
#
lav_matrix_cov_wt <- function(Y, wt = NULL) {
  Y <- unname(as.matrix.default(Y))
  DIM <- dim(Y)

  if (is.null(wt)) {
    wt <- rep(1, nrow(Y))
  }

  if (anyNA(Y)) {
    tmp <- na.omit(cbind(Y, wt))
    Y <- tmp[, seq_len(DIM[2]), drop = FALSE]
    wt <- tmp[, DIM[2] + 1L]
    DIM[1] <- nrow(Y)
    w.mean <- .colSums(wt * Y, m = DIM[1], n = DIM[2]) / sum(wt)
    Ytc <- t(t(Y) - w.mean)
    tmp <- crossprod(sqrt(wt) * Ytc)
    out <- tmp / sum(wt)
  } else {
    w.mean <- .colSums(wt * Y, m = DIM[1], n = DIM[2]) / sum(wt)
    Ytc <- t(t(Y) - w.mean)
    tmp <- crossprod(sqrt(wt) * Ytc)
    out <- tmp / sum(wt)
  }

  out
}

# compute (I-A)^{-1} where A is square
# using a (truncated) Neumann series:  (I-A)^{-1} = \sum_k=0^{\infty} A^k
#                                                 = I + A + A^2 + A^3 + ...
#
# note: this only works if the largest eigenvalue for A is < 1; but if A
#       represents regressions, the diagonal will be zero, and all eigenvalues
#       are zero
#
# as A is typically sparse, we can stop if all elements in A^k are zero for,
# say, k<=6
lav_matrix_inverse_iminus <- function(A = NULL) {
  nr <- nrow(A)
  nc <- ncol(A)
  stopifnot(nr == nc)

  # create I + A
  IA <- A
  diag.idx <- lav_matrix_diag_idx(nr)
  IA[diag.idx] <- IA[diag.idx] + 1

  # initial approximation
  IA.inv <- IA

  # first order
  A2 <- A %*% A
  if (all(A2 == 0)) {
    # we are done
    return(IA.inv)
  } else {
    IA.inv <- IA.inv + A2
  }

  # second order
  A3 <- A2 %*% A
  if (all(A3 == 0)) {
    # we are done
    return(IA.inv)
  } else {
    IA.inv <- IA.inv + A3
  }

  # third order
  A4 <- A3 %*% A
  if (all(A4 == 0)) {
    # we are done
    return(IA.inv)
  } else {
    IA.inv <- IA.inv + A4
  }

  # fourth order
  A5 <- A4 %*% A
  if (all(A5 == 0)) {
    # we are done
    return(IA.inv)
  } else {
    IA.inv <- IA.inv + A5
  }

  # fifth order
  A6 <- A5 %*% A
  if (all(A6 == 0)) {
    # we are done
    return(IA.inv)
  } else {
    # naive version (for now)
    tmp <- -A
    tmp[diag.idx] <- tmp[diag.idx] + 1
    IA.inv <- solve(tmp)
    return(IA.inv)
  }
}

# various ways to compute a (scaled) difference chi-square test statistic

# - 0.6-13: fix multiple-group UG^2 bug in Satorra.2000 (reported by
#           Gronneberg, Foldnes and Moss) when Satterthwaite = TRUE and
#           ngroups > 1L (use old.approach = TRUE to get the old result)

lav_test_diff_Satorra2000 <- function(m1, m0, H1 = TRUE, A.method = "delta",
                                      A = NULL,
                                      Satterthwaite = FALSE,
                                      scaled.shifted = FALSE,
                                      old.approach = FALSE) {
  if (scaled.shifted) {
    Satterthwaite <- TRUE
  }

  # extract information from m1 and m2
  T1 <- m1@test[[1]]$stat
  r1 <- m1@test[[1]]$df

  T0 <- m0@test[[1]]$stat
  r0 <- m0@test[[1]]$df

  # m = difference between the df's
  m <- r0 - r1

  # check for identical df setting
  if (m == 0L) {
    return(list(
      T.delta = (T0 - T1), scaling.factor = as.numeric(NA),
      df.delta = m, a = as.numeric(NA), b = as.numeric(NA)
    ))
  }

  # check for (near) identical test statistics (despite m > 0)
  if (abs(T1 - T0) < sqrt(.Machine$double.eps)) {
    lav_msg_warn(gettext("the test statistic of the restriced model is (nearly)
                         identical to the test statistic of the full model;
                         check your models."))
  }


  # bail out here, if m == 0 (but we should catch this earlier)
  # if(m < 1L) {
  #    txt <- paste("Can not compute (scaled) difference test when ",
  #                 "the degrees of freedom (df) are the same for both ",
  #                 "models:\n",
  #                 "Df model 1 = ", r1, ", and Df model 2 = ", r0, "\n",
  #                 sep = "")
  #            stop(lav_txt2message(txt, header = "lavaan ERROR:"))
  # }

  Gamma <- lavTech(m1, "Gamma") # the same for m1 and m0
  # check for NULL
  if (is.null(Gamma)) {
    lav_msg_stop(gettext(
      "can not compute Gamma matrix; perhaps missing = \"ml\"?"))
  }

  if (H1) {
    WLS.V <- lavTech(m1, "WLS.V")
    PI <- lav_model_delta(m1@Model)
    P <- lavTech(m1, "information")
    # needed? (yes, if H1 already has eq constraints)
    P.inv <- lav_model_information_augment_invert(m1@Model,
      information = P,
      inverted = TRUE
    )
    # compute 'A' matrix
    # NOTE: order of parameters may change between H1 and H0, so be
    # careful!
    if (is.null(A)) {
      A <- lav_test_diff_A(m1, m0, method = A.method, reference = "H1")
      # take into account equality constraints m1
      if (A.method == "delta") {
        if (m1@Model@eq.constraints) {
          A <- A %*% t(m1@Model@eq.constraints.K)
        } else if (m1@Model@ceq.simple.only) {
          A <- A %*% t(m1@Model@ceq.simple.K)
        }
      }
      if (lav_debug()) print(A)
    }
  } else {
    lav_msg_stop(gettext("not ready yet"))

    WLS.V <- lavTech(m0, "WLS.V")
    PI <- lav_model_delta(m0@Model)
    P <- lavTech(m0, "information")
    # needed?
    P.inv <- lav_model_information_augment_invert(m0@Model,
      information = P,
      inverted = TRUE
    )

    # compute 'A' matrix
    # NOTE: order of parameters may change between H1 and H0, so be
    # careful!
    if (is.null(A)) {
      # m1, m0 OR m0, m1 (works for delta, but not for exact)
      A <- lav_test_diff_A(m1, m0, method = A.method, reference = "H0")
      # take into account equality constraints m1
      if (m0@Model@eq.constraints) {
        A <- A %*% t(m0@Model@eq.constraints.K)
      } else if (m0@Model@ceq.simple.only) {
        A <- A %*% t(m0@Model@ceq.simple.K)
      }
      if (lav_debug()) print(A)
    }
  }

  # compute tr UG per group
  ngroups <- m1@SampleStats@ngroups
  UG.group <- vector("list", length = ngroups)

  # safety check: A %*% P.inv %*% t(A) should NOT contain all-zero
  # rows/columns
  # FIXME: is this really needed? As we use ginv later on
  APA <- A %*% P.inv %*% t(A)
  cSums <- colSums(APA)
  rSums <- rowSums(APA)
  empty.idx <- which(abs(cSums) < .Machine$double.eps^0.5 &
    abs(rSums) < .Machine$double.eps^0.5)
  if (length(empty.idx) > 0) {
    A <- A[-empty.idx, , drop = FALSE]
  }
  if (nrow(A) == 0L) {
    # oops... abort!
    return(list(
      T.delta = (T0 - T1), scaling.factor = as.numeric(NA),
      df.delta = m, a = as.numeric(NA), b = as.numeric(NA)
    ))
  }

  # PAAPAAP
  PAAPAAP <- P.inv %*% t(A) %*% MASS::ginv(A %*% P.inv %*% t(A)) %*% A %*% P.inv

  # compute scaling factor
  fg <- unlist(m1@SampleStats@nobs) / m1@SampleStats@ntotal


  # this is what we did <0.6-13
  if (old.approach) {
    trace.UGamma <- numeric(ngroups)
    trace.UGamma2 <- numeric(ngroups)
    for (g in 1:ngroups) {
      UG.group <- WLS.V[[g]] %*% Gamma[[g]] %*% WLS.V[[g]] %*%
        PI[[g]] %*% PAAPAAP %*% t(PI[[g]])
      trace.UGamma[g] <- sum(diag(UG.group))
      if (Satterthwaite) {
        trace.UGamma2[g] <- sum(diag(UG.group %*% UG.group))
      }
    }

    trace.UGamma <- sum(fg * trace.UGamma)
    if (Satterthwaite) {
      trace.UGamma2 <- sum(fg * trace.UGamma2)
    }
  } else {
    # for trace.UGamma, we can compute the trace per group
    # as in Satorra (2000) eq. 23
    trace.UGamma <- numeric(ngroups)
    for (g in 1:ngroups) {
      UG.group <- WLS.V[[g]] %*% Gamma[[g]] %*% WLS.V[[g]] %*%
        PI[[g]] %*% PAAPAAP %*% t(PI[[g]])
      trace.UGamma[g] <- sum(diag(UG.group))
    }
    trace.UGamma <- sum(fg * trace.UGamma)

    # but for trace.UGamma2, we can no longer compute the trace per group
    trace.UGamma2 <- as.numeric(NA)
    if (Satterthwaite) {
      # global approach (not group-specific)
      Gamma.f <- Gamma
      for (g in seq_along(Gamma)) {
        Gamma.f[[g]] <- fg[g] * Gamma[[g]]
      }
      Gamma.all <- lav_matrix_bdiag(Gamma.f)
      V.all <- lav_matrix_bdiag(WLS.V)
      PI.all <- do.call(rbind, PI)
      U.all <- V.all %*% PI.all %*% PAAPAAP %*% t(PI.all) %*% V.all
      UG.all <- U.all %*% Gamma.all
      UG.all2 <- UG.all %*% UG.all
      trace.UGamma2 <- sum(diag(UG.all2))
    }
  }

  if (Satterthwaite && !scaled.shifted) {
    cd <- trace.UGamma2 / trace.UGamma
    df.delta <- trace.UGamma^2 / trace.UGamma2
    T.delta <- (T0 - T1) / cd
    a <- as.numeric(NA)
    b <- as.numeric(NA)
  } else if (Satterthwaite && scaled.shifted) {
    a <- sqrt(m / trace.UGamma2)
    # b <- m - sqrt(m * trace.UGamma^2 / trace.UGamma2)
    b <- m - a * trace.UGamma
    df.delta <- m
    T.delta <- (T0 - T1) * a + b
    cd <- as.numeric(NA)
  } else {
    cd <- 1 / m * trace.UGamma
    df.delta <- m
    T.delta <- (T0 - T1) / cd
    a <- as.numeric(NA)
    b <- as.numeric(NA)
  }

  list(
    T.delta = T.delta, scaling.factor = cd, df.delta = df.delta,
    trace.UGamma = trace.UGamma, trace.UGamma2 = trace.UGamma2,
    a = a, b = b
  )
}

lav_test_diff_SatorraBentler2001 <- function(m1, m0, test = 2) {
  # extract information from m1 and m2
  T1 <- m1@test[[1]]$stat
  r1 <- m1@test[[1]]$df
  c1 <- m1@test[[test]]$scaling.factor

  ## check for situations when scaling.factor would be NA
  if (r1 == 0) {
    ## saturated model
    c1 <- 1 # canceled out by 0 when calculating "cd"

  } else if (r1 > 0 && isTRUE(all.equal(T1, 0))) {
    ## perfect fit
    c1 <- 0 # cancels out r1 when calculating "cd"
  }

  T0 <- m0@test[[1]]$stat
  r0 <- m0@test[[1]]$df
  c0 <- m0@test[[test]]$scaling.factor

  # m = difference between the df's
  m <- r0 - r1

  # check for identical df setting
  if (m == 0L) {
    return(list(
      T.delta = (T0 - T1), scaling.factor = as.numeric(NA),
      df.delta = m
    ))
  }

  # compute c_d
  cd <- (r0 * c0 - r1 * c1) / m

  # warn if cd is negative
  if (cd < 0) {
    lav_msg_warn(gettext("scaling factor is negative"))
    cd <- as.numeric(NA)
  }

  # compute scaled difference test
  T.delta <- (T0 - T1) / cd

  list(T.delta = T.delta, scaling.factor = cd, df.delta = m)
}

lav_test_diff_SatorraBentler2010 <- function(m1, m0, test = 2,
                                             H1 = FALSE) {
  ### FIXME: check if models are nested at the parameter level!!!

  # extract information from m1 and m2
  T1 <- m1@test[[1]]$stat
  r1 <- m1@test[[1]]$df
  c1 <- m1@test[[test]]$scaling.factor
  if (r1 == 0) { # saturated model
    c1 <- 1
  }

  T0 <- m0@test[[1]]$stat
  r0 <- m0@test[[1]]$df
  c0 <- m0@test[[test]]$scaling.factor
  if (r0 == 0) { # should never happen
    c0 <- 1
  }

  # m = difference between the df's
  m <- r0 - r1

  # check for identical df setting
  if (m == 0L) {
    return(list(
      T.delta = (T0 - T1), scaling.factor = as.numeric(NA),
      df.delta = m
    ))
  }

  # generate `M10' model
  if (H1) {
    # M0 with M1 parameters
    M01 <- lav_test_diff_m10(m0, m1, test = TRUE)
    c01 <- M01@test[[test]]$scaling.factor

    # check if vcov is positive definite (new in 0.6)
    # if not, we may get negative values
    eigvals <- eigen(lavTech(M01, "information"),
      symmetric = TRUE, only.values = TRUE
    )$values
    if (any(eigvals < -1 * .Machine$double.eps^(3 / 4))) {
      lav_msg_warn(gettext(
        "information matrix of the M01 model is not positive definite."
      ))
      # "                  As a result, the scale-factor can not be computed.")
      # cd <- as.numeric(NA)
    } # else {
    # compute c_d
    # cd.01 <- (r0 * c01 - r1 * c0) / m ???
    cd <- (r0 * c0 - r1 * c01) / m
    # }
  } else {
    # M1 with M0 parameters (as in Satorra & Bentler 2010)
    M10 <- lav_test_diff_m10(m1, m0, test = TRUE)
    c10 <- M10@test[[test]]$scaling.factor

    # check if vcov is positive definite (new in 0.6)
    # if not, we may get negative values
    eigvals <- eigen(lavTech(M10, "information"),
      symmetric = TRUE, only.values = TRUE
    )$values
    if (any(eigvals < -1 * .Machine$double.eps^(3 / 4))) {
      lav_msg_warn(gettext(
        "information matrix of the M10 model is not positive definite."
      ))
      # "                  As a result, the scale-factor can not be computed.")
      # cd <- as.numeric(NA)
    } # else {
    # compute c_d
    cd <- (r0 * c0 - r1 * c10) / m
    # }
  }

  # compute scaled difference test
  T.delta <- (T0 - T1) / cd

  list(
    T.delta = T.delta, scaling.factor = cd, df.delta = m,
    T.delta.unscaled = (T0 - T1)
  )
}

# create a new model 'm10', where we use model 'm1', but we
# inject it with the values of 'm0'
lav_test_diff_m10 <- function(m1, m0, test = FALSE) {
  # switch of verbose/se/test
  Options <- m1@Options
  # switch of optim.gradient check
  Options$check.gradient <- FALSE

  # should we compute se/test statistics?
  if (!test) {
    Options$se <- "none"
    Options$test <- "none"
  }

  PT.M0 <- lav_partable_set_cache(m0@ParTable, m0@pta)
  PT.M1 <- lav_partable_set_cache(m1@ParTable, m1@pta)

  # `extend' PT.M1 partable to include all `fixed-to-zero parameters'
  PT.M1.FULL <- lav_partable_full(
    partable = PT.M1,
    free = TRUE, start = TRUE
  )
  PT.M1.extended <- lav_partable_merge(PT.M1, PT.M1.FULL,
    remove.duplicated = TRUE, warn = FALSE
  )

  # remove most columns
  PT.M1.extended$start <- NULL # new in 0.6-4! (otherwise, they are used)
  PT.M1.extended$est <- NULL
  PT.M1.extended$se <- NULL

  # in addition, use 'NA' for free parameters in ustart column
  free.par.idx <- which(PT.M1.extended$free > 0L)
  PT.M1.extended$ustart[free.par.idx] <- as.numeric(NA)

  # `extend' PT.M0 partable to include all `fixed-to-zero parameters'
  PT.M0.FULL <- lav_partable_full(
    partable = PT.M0,
    free = TRUE, start = TRUE
  )
  PT.M0.extended <- lav_partable_merge(PT.M0, PT.M0.FULL,
    remove.duplicated = TRUE, warn = FALSE
  )
  # remove most columns, but not 'est'
  PT.M0.extended$ustart <- NULL
  PT.M0.extended$start <- NULL
  PT.M0.extended$se <- NULL


  # FIXME:
  # - check if H0 does not contain additional parameters...

  Options$optim.method <- "none"
  Options$optim.force.converged <- TRUE
  Options$baseline <- FALSE
  Options$h1 <- TRUE # needed after all (yuan.benter.mplus)
  Options$start <- PT.M0.extended # new in 0.6!
  m10 <- lavaan(
    model = PT.M1.extended,
    slotOptions = Options,
    slotSampleStats = m1@SampleStats,
    slotData = m1@Data,
    slotCache = m1@Cache,
    verbose = FALSE
  )

  m10
}

# compute the `A' matrix: the jacobian of the constraint function a(\delta)
# (see Satorra 2000)
#
#
#
lav_test_diff_A <- function(m1, m0, method = "delta", reference = "H1") {
  # FIXME!!!!

  if (method == "exact") {
    if (reference == "H1") {
      af <- lav_test_diff_af_h1(m1 = m1, m0 = m0)
      xx <- m1@optim$x
    } else { # evaluate under H0
      lav_msg_stop(gettext("not ready yet"))
      # af <- .test_compute_partable_A_diff_h0(m1 = m1, m0 = m0)
      xx <- m0@optim$x
    }
    A <- try(lav_func_jacobian_complex(func = af, x = xx), silent = TRUE)
    if (inherits(A, "try-error")) {
      A <- lav_func_jacobian_simple(func = af, x = xx)
    }
  } else if (method == "delta") {
    # use a numeric approximation of `A'
    Delta1.list <- lav_model_delta(m1@Model)
    Delta0.list <- lav_model_delta(m0@Model)
    Delta1 <- do.call(rbind, Delta1.list)
    Delta0 <- do.call(rbind, Delta0.list)

    # take into account equality constraints m0
    if (m0@Model@eq.constraints) {
      Delta0 <- Delta0 %*% m0@Model@eq.constraints.K
    } else if (m0@Model@ceq.simple.only) {
      Delta0 <- Delta0 %*% t(m0@Model@ceq.simple.K)
    }

    # take into account equality constraints m1
    if (m1@Model@eq.constraints) {
      Delta1 <- Delta1 %*% m1@Model@eq.constraints.K
    } else if (m1@Model@ceq.simple.only) {
      Delta1 <- Delta1 %*% t(m1@Model@ceq.simple.K)
    }

    # H <- solve(t(Delta1) %*% Delta1) %*% t(Delta1) %*% Delta0
    H <- MASS::ginv(Delta1) %*% Delta0
    A <- t(lav_matrix_orthogonal_complement(H))
  }

  A
}


# for each parameter in H1 (m1), see if we have somehow constrained
# this parameter under H0 (m0)
#
# since we work 'under H0', we need to use the labels/constraints/def
# as they appear in H0. Unfortunately, the order of the parameters, and
# even the (p)labels may be different in the two models...
#
# Therefore, we will attempt to:
#   - change the 'order' of the 'free' column in m0, so that they map to
#     to the 'x' that we will provide from H1
#   - the plabels used in "==" constraints must be renamed, if necessary
#
lav_test_diff_af_h1 <- function(m1, m0) {
  PT.M0 <- lav_partable_set_cache(parTable(m0), m0@pta)
  PT.M1 <- lav_partable_set_cache(parTable(m1), m1@pta)

  # select .p*. parameters only
  M0.p.idx <- which(grepl("\\.p", PT.M0$plabel))
  np0 <- length(M0.p.idx)
  M1.p.idx <- which(grepl("\\.p", PT.M1$plabel))
  np1 <- length(M1.p.idx)

  # check if parameter space is the same
  if (np0 != np1) {
    lav_msg_stop(gettext(
      "unconstrained parameter set is not the same in m0 and m1"))
  }

  # split partable in 'parameter' and 'constraints' section
  PT.M0.part1 <- PT.M0[M0.p.idx, ]
  PT.M0.part2 <- PT.M0[-M0.p.idx, ]

  PT.M1.part1 <- PT.M1[M1.p.idx, ]
  PT.M1.part2 <- PT.M1[-M1.p.idx, ]

  # figure out relationship between m0 and m1
  p1.id <- lav_partable_map_id_p1_in_p2(PT.M0.part1, PT.M1.part1)
  p0.free.idx <- which(PT.M0.part1$free > 0)

  # change 'free' order in m0
  # NOTE: this only works all the free parameters in h0 are also free
  # in h1 (and if not, they will become fixed in h0)
  PT.M0.part1$free[p0.free.idx] <-
    PT.M1.part1$free[PT.M0.part1$id[p1.id][p0.free.idx]]

  # paste back
  PT.M0 <- rbind(PT.M0.part1, PT.M0.part2)
  PT.M1 <- rbind(PT.M1.part1, PT.M1.part2)

  # `extend' PT.M1 partable to include all `fixed-to-zero parameters'
  PT.M1.FULL <- lav_partable_full(
    partable = PT.M1,
    free = TRUE, start = TRUE
  )
  PT.M1.extended <- lav_partable_merge(PT.M1, PT.M1.FULL,
    remove.duplicated = TRUE, warn = FALSE
  )

  # `extend' PT.M0 partable to include all `fixed-to-zero parameters'
  PT.M0.FULL <- lav_partable_full(
    partable = PT.M0,
    free = TRUE, start = TRUE
  )
  PT.M0.extended <- lav_partable_merge(PT.M0, PT.M0.FULL,
    remove.duplicated = TRUE, warn = FALSE
  )

  p1 <- PT.M1.extended
  np1 <- length(p1$lhs)
  p0 <- PT.M0.extended
  np0 <- length(p0$lhs)

  con.function <- function() NULL
  formals(con.function) <- alist(.x. = , ... = )
  BODY.txt <- paste("{\nout <- numeric(0L)\n", sep = "")


  # first handle def + == constraints
  # but FIRST, remove == constraints that also appear in H1!!!

  # remove equivalent eq constraints from p0
  P0 <- p0

  p0.eq.idx <- which(p0$op == "==")
  p1.eq.idx <- which(p1$op == "==")
  p0.remove.idx <- integer(0L)
  if (length(p0.eq.idx) > 0L) {
    for (i in seq_along(p0.eq.idx)) {
      # e0 in p0
      e0 <- p0.eq.idx[i]
      lhs <- p0$lhs[e0]
      rhs <- p0$rhs[e0]

      # do we have an equivalent constraint in H1?
      # NOTE!! the (p)labels may differ

      # SO, we will use an 'empirical' approach: if we fill in (random)
      # values, and work out the constraint, do we get identical values?
      # if yes, constraint is equivalent, and we should NOT add it here

      if (length(p1.eq.idx) > 0) {
        # generate random parameter values
        xx1 <- rnorm(length(M1.p.idx))
        xx0 <- xx1[p1.id]

        con.h0.value <- m0@Model@ceq.function(xx0)[i]
        con.h1.values <- m1@Model@ceq.function(xx1)

        if (con.h0.value %in% con.h1.values) {
          p0.remove.idx <- c(p0.remove.idx, e0)
        }
      }
    }
  }
  if (length(p0.remove.idx) > 0L) {
    P0 <- P0[-p0.remove.idx, ]
  }

  # only for the UNIQUE equality constraints in H0, generate syntax
  DEFCON.txt <- lav_partable_constraints_ceq(P0, txtOnly = TRUE)
  BODY.txt <- paste(BODY.txt, DEFCON.txt, "\n", sep = "")


  # for each parameter in p1, we 'check' is it is fixed to a constant in p0
  ncon <- length(which(P0$op == "=="))
  for (i in seq_len(np1)) {
    # p in p1
    lhs <- p1$lhs[i]
    op <- p1$op[i]
    rhs <- p1$rhs[i]
    group <- p1$group[i]

    # ignore '==', '<', '>' and ':=' for now
    if (op == "==" || op == ">" || op == "<" || op == ":=") next

    # search for corresponding parameter in p0
    p0.idx <- which(p0$lhs == lhs & p0$op == op & p0$rhs == rhs &
      p0$group == group)
    if (length(p0.idx) == 0L) {
      lav_msg_stop(
        gettextf("parameter in H1 not found in H0: %s",
        paste(lhs, op, rhs, "(group = ", group, ")", sep = " ")
      ))
    }

    # 4 possibilities: p is free/fixed in p1, p is free/fixed in p0
    if (p1$free[i] == 0L) {
      if (p0$free[p0.idx] == 0L) {
        # match, nothing to do
      } else {
        lav_msg_warn(
          gettextf("fixed parameter in H1 is free in H0: %s",
          paste("\"", lhs, " ", op, " ", rhs,
            "\" (group = ", group, ")",
            sep = ""
          )
        ))
      }
    } else {
      if (p0$free[p0.idx] == 0L) {
        # match, this is a contrained parameter in H0
        ncon <- ncon + 1L
        BODY.txt <- paste(BODY.txt,
          "out[", ncon, "] = .x.[", p1$free[i], "] - ",
          p0$ustart[p0.idx], "\n",
          sep = ""
        )
        next
      } else {
        # match, nothing to do
      }
    }
  }


  # wrap function
  BODY.txt <- paste(BODY.txt, "return(out)\n}\n", sep = "")
  body(con.function) <- parse(file = "", text = BODY.txt)

  con.function
}

# and matrix-representation specific functions:
# - lav_model_sigma
# - lav_model_mu
# - derivative.F

# initital version: YR 2011-01-21: LISREL stuff
# updates:          YR 2011-12-01: group specific extraction
#                   YR 2012-05-17: thresholds
#                   YR 2021-10-04: rename representation.LISREL -> lav_lisrel

lav_lisrel <- function(lavpartable = NULL,
                       target = NULL,
                       extra = FALSE,
                       allow.composites = TRUE,
                       remove.nonexisting = TRUE) {
  # prepare target list
  if (is.null(target)) target <- lavpartable

  stopifnot(!is.null(target$block))

  # prepare output
  N <- length(target$lhs)
  tmp.mat <- character(N)
  tmp.row <- integer(N)
  tmp.col <- integer(N)

  # global settings
  meanstructure <- any(lavpartable$op == "~1")
  categorical <- any(lavpartable$op == "|")
  composites <- any(lavpartable$op == "<~") && allow.composites
  group.w.free <- any(lavpartable$lhs == "group" & lavpartable$op == "%")

  # gamma?only if conditional.x
  if (any(lavpartable$op %in% c("~", "<~") & lavpartable$exo == 1L) &&
      !composites) {
    gamma <- TRUE
  } else {
    gamma <- FALSE
  }

  # number of blocks
  nblocks <- lav_partable_nblocks(lavpartable)

  # multilevel?
  nlevels <- lav_partable_nlevels(lavpartable)
  ngroups <- lav_partable_ngroups(lavpartable)

  ov.dummy.names.nox <- vector("list", nblocks)
  ov.dummy.names.x <- vector("list", nblocks)
  if (extra) {
    REP.mmNames <- vector("list", nblocks)
    REP.mmNumber <- vector("list", nblocks)
    REP.mmRows <- vector("list", nblocks)
    REP.mmCols <- vector("list", nblocks)
    REP.mmDimNames <- vector("list", nblocks)
    REP.mmSymmetric <- vector("list", nblocks)
  }

  for (g in 1:nblocks) {
    # info from user model per block
    if (gamma) {
      ov.names <- lav_partable_vnames(lavpartable, "ov.nox", block = g)
    } else {
      ov.names <- lav_partable_vnames(lavpartable, "ov", block = g)
    }
    nvar <- length(ov.names)
    lv.names <- lav_partable_vnames(lavpartable, "lv", block = g)
    nfac <- length(lv.names)
    ov.th <- lav_partable_vnames(lavpartable, "th", block = g)
    nth <- length(ov.th)
    ov.names.x <- lav_partable_vnames(lavpartable, "ov.x", block = g)
    nexo <- length(ov.names.x)
    ov.names.nox <- lav_partable_vnames(lavpartable, "ov.nox", block = g)

    # in this representation, we need to create 'phantom/dummy' latent
    # variables for all `x' and `y' variables not in lv.names
    # (only y if conditional.x = TRUE)

    # regression dummys
    if (gamma) {
      tmp.names <-
        unique(lavpartable$lhs[(lavpartable$op == "~" |
          lavpartable$op == "<~") &
          lavpartable$block == g])
      # new in 0.6-12: fix for multilevel + conditional.x: splitted ov.x
      # are removed from ov.x
      if (nlevels > 1L) {
        if (ngroups == 1L) {
          OTHER.BLOCK.NAMES <- lav_partable_vnames(lavpartable, "ov",
            block = seq_len(nblocks)[-g]
          )
        } else {
          # TEST ME
          this.group <- ceiling(g / nlevels)
          blocks.within.group <- (this.group - 1L) * nlevels + seq_len(nlevels)
          OTHER.BLOCK.NAMES <- lav_partable_vnames(lavpartable,
            "ov",
            block = blocks.within.group[-g]
          )
        }
        if (length(ov.names.x) > 0L) {
          idx <- which(ov.names.x %in% OTHER.BLOCK.NAMES)
          if (length(idx) > 0L) {
            tmp.names <- unique(c(tmp.names, ov.names.x[idx]))
            ov.names.nox <- unique(c(ov.names.nox, ov.names.x[idx]))
            ov.names.x <- ov.names.x[-idx]
            nexo <- length(ov.names.x)
            ov.names <- ov.names.nox
            nvar <- length(ov.names)
          }
        }
      }
    } else {
      if (composites) {
        tmp.names <-
          unique(c(
            lavpartable$lhs[(lavpartable$op == "~") &
              lavpartable$block == g],
            lavpartable$rhs[(lavpartable$op == "~") &
              lavpartable$block == g]
          ))
      } else {
        # old behavior < 0.6-20
        tmp.names <-
          unique(c(
            lavpartable$lhs[(lavpartable$op == "~" |
              lavpartable$op == "<~") &
              lavpartable$block == g],
            lavpartable$rhs[(lavpartable$op == "~" |
              lavpartable$op == "<~") &
              lavpartable$block == g]
          ))
      }
    }
    dummy.names1 <- tmp.names[!tmp.names %in% lv.names]
    # covariances involving dummys
    dummy.cov.idx <- which(lavpartable$op == "~~" & lavpartable$block == g &
      (lavpartable$lhs %in% dummy.names1 |
        lavpartable$rhs %in% dummy.names1))
    # new in 0.5-21: also include covariances involving these covariances...
    dummy.cov.idx1 <- which(lavpartable$op == "~~" & lavpartable$block == g &
      (lavpartable$lhs %in% lavpartable$lhs[dummy.cov.idx] |
        lavpartable$rhs %in% lavpartable$rhs[dummy.cov.idx]))
    dummy.cov.idx <- unique(c(dummy.cov.idx, dummy.cov.idx1))

    dummy.names2 <- unique(c(
      lavpartable$lhs[dummy.cov.idx],
      lavpartable$rhs[dummy.cov.idx]
    ))


    # new in 0.6-7: ~~ between latent and observed
    dummy.cov.ov.lv.idx1 <- which(lavpartable$op == "~~" &
      lavpartable$block == g &
      lavpartable$lhs %in% ov.names &
      lavpartable$rhs %in% lv.names)
    dummy.cov.ov.lv.idx2 <- which(lavpartable$op == "~~" &
      lavpartable$block == g &
      lavpartable$lhs %in% lv.names &
      lavpartable$rhs %in% ov.names)
    dummy.names3 <- unique(c(
      lavpartable$lhs[dummy.cov.ov.lv.idx1],
      lavpartable$rhs[dummy.cov.ov.lv.idx2]
    ))

    # new in 0.6-10: ~~ between observed and observed, but not in ~
    dummy.orphan.idx <- which(lavpartable$op == "~~" &
      lavpartable$block == g &
      lavpartable$lhs %in% ov.names &
      lavpartable$rhs %in% ov.names &
      (!lavpartable$lhs %in% c(
        dummy.names1,
        dummy.names2
      ) |
        !lavpartable$rhs %in% c(
          dummy.names1,
          dummy.names2
        )))

    # collect all dummy variables
    dummy.names <- unique(c(dummy.names1, dummy.names2, dummy.names3))


    if (length(dummy.names)) {
      # make sure order is the same as ov.names
      ov.dummy.names.nox[[g]] <-
        ov.names.nox[ov.names.nox %in% dummy.names]
      ov.dummy.names.x[[g]] <-
        ov.names.x[ov.names.x %in% dummy.names]

      # combine them, make sure order is identical to ov.names
      tmp <- ov.names[ov.names %in% dummy.names]

      # same for ov.names.x (if they are not in ov.names) (conditional.x)
      if (length(ov.names.x) > 0L) {
        tmp.x <- ov.names.x[ov.names.x %in% dummy.names]
        tmp <- unique(c(tmp, tmp.x))
      }

      # extend lv.names
      lv.names <- c(lv.names, tmp)
      nfac <- length(lv.names)

      # add 'dummy' =~ entries
      dummy.mat <- rep("lambda", length(dummy.names))
    } else {
      ov.dummy.names.nox[[g]] <- character(0)
      ov.dummy.names.x[[g]] <- character(0)
    }

    # 1a. "=~" regular indicators
    idx <- which(target$block == g &
      target$op == "=~" & !(target$rhs %in% lv.names))
    tmp.mat[idx] <- "lambda"
    tmp.row[idx] <- match(target$rhs[idx], ov.names)
    tmp.col[idx] <- match(target$lhs[idx], lv.names)

    # 1b. "=~" regular higher-order lv indicators
    idx <- which(target$block == g &
      target$op == "=~" & !(target$rhs %in% ov.names))
    tmp.mat[idx] <- "beta"
    tmp.row[idx] <- match(target$rhs[idx], lv.names)
    tmp.col[idx] <- match(target$lhs[idx], lv.names)

    # 1c. "=~" indicators that are both in ov and lv
    idx <- which(target$block == g &
      target$op == "=~" & target$rhs %in% ov.names &
      target$rhs %in% lv.names)
    tmp.mat[idx] <- "beta"
    tmp.row[idx] <- match(target$rhs[idx], lv.names)
    tmp.col[idx] <- match(target$lhs[idx], lv.names)

    # 1d. "<~" indicators
    if (composites) {
      idx <- which(target$block == g &
        target$op == "<~" & !(target$rhs %in% lv.names))
      tmp.mat[idx] <- "wmat"
      tmp.row[idx] <- match(target$rhs[idx], ov.names)
      tmp.col[idx] <- match(target$lhs[idx], lv.names)
    }

    # 2. "~" regressions
    if (gamma) {
      # gamma
      if (composites) {
        idx <- which(target$rhs %in% ov.names.x &
          target$block == g & target$op == "~")
      } else {
        idx <- which(target$rhs %in% ov.names.x &
          target$block == g & (target$op == "~" |
          target$op == "<~"))
      }
      tmp.mat[idx] <- "gamma"
      tmp.row[idx] <- match(target$lhs[idx], lv.names)
      tmp.col[idx] <- match(target$rhs[idx], ov.names.x)

      # beta
      if (composites) {
        idx <- which(!target$rhs %in% ov.names.x &
          target$block == g & target$op == "~")
      } else {
        idx <- which(!target$rhs %in% ov.names.x &
          target$block == g & (target$op == "~" |
          target$op == "<~"))
      }
      tmp.mat[idx] <- "beta"
      tmp.row[idx] <- match(target$lhs[idx], lv.names)
      tmp.col[idx] <- match(target$rhs[idx], lv.names)
    } else {
      if (composites) {
        idx <- which(target$block == g & target$op == "~")
      } else {
        idx <- which(target$block == g & (target$op == "~" |
          target$op == "<~"))
      }
      tmp.mat[idx] <- "beta"
      tmp.row[idx] <- match(target$lhs[idx], lv.names)
      tmp.col[idx] <- match(target$rhs[idx], lv.names)
    }

    # 3a. "~~" ov
    idx <- which(target$block == g &
      target$op == "~~" & !(target$lhs %in% lv.names))
    tmp.mat[idx] <- "theta"
    tmp.row[idx] <- match(target$lhs[idx], ov.names)
    tmp.col[idx] <- match(target$rhs[idx], ov.names)

    # 3aa. "~~" ov.x
    if (gamma) {
      idx <- which(target$block == g &
        target$op == "~~" & (target$lhs %in% ov.names.x))
      tmp.mat[idx] <- "cov.x"
      tmp.row[idx] <- match(target$lhs[idx], ov.names.x)
      tmp.col[idx] <- match(target$rhs[idx], ov.names.x)
    }

    # 3b. "~~" lv
    idx <- which(target$block == g &
      target$op == "~~" & target$rhs %in% lv.names)
    tmp.mat[idx] <- "psi"
    tmp.row[idx] <- match(target$lhs[idx], lv.names)
    tmp.col[idx] <- match(target$rhs[idx], lv.names)

    # 4a. "~1" ov
    idx <- which(target$block == g &
      target$op == "~1" & !(target$lhs %in% lv.names))
    tmp.mat[idx] <- "nu"
    tmp.row[idx] <- match(target$lhs[idx], ov.names)
    tmp.col[idx] <- 1L

    # 4aa, "~1" ov.x
    if (gamma) {
      idx <- which(target$block == g &
        target$op == "~1" & (target$lhs %in% ov.names.x))
      tmp.mat[idx] <- "mean.x"
      tmp.row[idx] <- match(target$lhs[idx], ov.names.x)
      tmp.col[idx] <- 1L
    }

    # 4b. "~1" lv
    idx <- which(target$block == g &
      target$op == "~1" & target$lhs %in% lv.names)
    tmp.mat[idx] <- "alpha"
    tmp.row[idx] <- match(target$lhs[idx], lv.names)
    tmp.col[idx] <- 1L

    # 5. "|" th
    LABEL <- paste(target$lhs, target$op, target$rhs, sep = "")
    idx <- which(target$block == g &
      target$op == "|" & LABEL %in% ov.th)
    TH <- paste(target$lhs[idx], "|", target$rhs[idx], sep = "")
    tmp.mat[idx] <- "tau"
    tmp.row[idx] <- match(TH, ov.th)
    tmp.col[idx] <- 1L

    # 6. "~*~" scales
    idx <- which(target$block == g &
      target$op == "~*~")
    tmp.mat[idx] <- "delta"
    tmp.row[idx] <- match(target$lhs[idx], ov.names)
    tmp.col[idx] <- 1L

    # new 0.5-12: catch lower-elements in theta/psi
    idx.lower <- which(tmp.mat %in% c("theta", "psi") & tmp.row > tmp.col)
    if (length(idx.lower) > 0L) {
      tmp <- tmp.row[idx.lower]
      tmp.row[idx.lower] <- tmp.col[idx.lower]
      tmp.col[idx.lower] <- tmp
    }

    # new 0.5-16: group weights
    idx <- which(target$block == g & target$lhs == "group" &
      target$op == "%")
    tmp.mat[idx] <- "gw"
    tmp.row[idx] <- 1L
    tmp.col[idx] <- 1L

    if (extra) {
      # mRows
      mmRows <- list(
        tau = nth,
        delta = nvar,
        nu = nvar,
        lambda = nvar,
        wmat = nvar,
        theta = nvar,
        alpha = nfac,
        beta = nfac,
        gamma = nfac,
        cov.x = nexo,
        mean.x = nexo,
        gw = 1L,
        psi = nfac
      )

      # mCols
      mmCols <- list(
        tau = 1L,
        delta = 1L,
        nu = 1L,
        lambda = nfac,
        wmat = nfac,
        theta = nvar,
        alpha = 1L,
        beta = nfac,
        gamma = nexo,
        cov.x = nexo,
        mean.x = 1L,
        gw = 1L,
        psi = nfac
      )

      # dimNames for LISREL model matrices
      mmDimNames <- list(
        tau = list(ov.th, "threshold"),
        delta = list(ov.names, "scales"),
        nu = list(ov.names, "intercept"),
        lambda = list(ov.names, lv.names),
        wmat = list(ov.names, lv.names),
        theta = list(ov.names, ov.names),
        alpha = list(lv.names, "intercept"),
        beta = list(lv.names, lv.names),
        gamma = list(lv.names, ov.names.x),
        cov.x = list(ov.names.x, ov.names.x),
        mean.x = list(ov.names.x, "intercepts"),
        gw = list("group", "weight"),
        psi = list(lv.names, lv.names)
      )

      # isSymmetric
      mmSymmetric <- list(
        tau = FALSE,
        delta = FALSE,
        nu = FALSE,
        lambda = FALSE,
        wmat = FALSE,
        theta = TRUE,
        alpha = FALSE,
        beta = FALSE,
        gamma = FALSE,
        cov.x = TRUE,
        mean.x = FALSE,
        gw = FALSE,
        psi = TRUE
      )

      # which mm's do we need? (always include lambda, theta and psi)
      # new: 0.6 this block only!!
      IDX <- which(target$block == g)
      if ("wmat" %in% tmp.mat[IDX]) {
        mmNames <- c("lambda", "wmat", "theta", "psi")
      } else {
        mmNames <- c("lambda", "theta", "psi")
      }

      if ("beta" %in% tmp.mat[IDX]) {
        mmNames <- c(mmNames, "beta")
      }
      if (meanstructure) {
        mmNames <- c(mmNames, "nu", "alpha")
      }
      if ("tau" %in% tmp.mat[IDX]) {
        mmNames <- c(mmNames, "tau")
      }
      if ("delta" %in% tmp.mat[IDX]) {
        mmNames <- c(mmNames, "delta")
      }
      if ("gamma" %in% tmp.mat[IDX]) {
        mmNames <- c(mmNames, "gamma")
      }
      if ("gw" %in% tmp.mat[IDX]) {
        mmNames <- c(mmNames, "gw")
      }
      if ("cov.x" %in% tmp.mat[IDX]) {
        mmNames <- c(mmNames, "cov.x")
      }
      if ("mean.x" %in% tmp.mat[IDX]) {
        mmNames <- c(mmNames, "mean.x")
      }

      REP.mmNames[[g]] <- mmNames
      REP.mmNumber[[g]] <- length(mmNames)
      REP.mmRows[[g]] <- unlist(mmRows[mmNames])
      REP.mmCols[[g]] <- unlist(mmCols[mmNames])
      REP.mmDimNames[[g]] <- mmDimNames[mmNames]
      REP.mmSymmetric[[g]] <- unlist(mmSymmetric[mmNames])
    } # extra
  } # nblocks

  REP <- list(
    mat = tmp.mat,
    row = tmp.row,
    col = tmp.col
  )

  # remove non-existing (NAs)?
  # here we remove `non-existing' parameters; this depends on the matrix
  # representation (eg in LISREL rep, there is no ~~ between lv and ov)
  # if(remove.nonexisting) {
  #    idx <- which( nchar(REP$mat) > 0L &
  #                 !is.na(REP$row) & REP$row > 0L &
  #                 !is.na(REP$col) & REP$col > 0L )
  #   # but keep ==, :=, etc.
  #   idx <- c(idx, which(lavpartable$op %in% c("==", ":=", "<", ">")))
  #   REP$mat <- REP$mat[idx]
  #   REP$row <- REP$row[idx]
  #   REP$col <- REP$col[idx]
  #

  # always add 'ov.dummy.*.names' attributes
  attr(REP, "ov.dummy.names.nox") <- ov.dummy.names.nox
  attr(REP, "ov.dummy.names.x") <- ov.dummy.names.x

  if (extra) {
    attr(REP, "mmNames") <- REP.mmNames
    attr(REP, "mmNumber") <- REP.mmNumber
    attr(REP, "mmRows") <- REP.mmRows
    attr(REP, "mmCols") <- REP.mmCols
    attr(REP, "mmDimNames") <- REP.mmDimNames
    attr(REP, "mmSymmetric") <- REP.mmSymmetric
  }

  REP
}


# ETA:
# 1) EETA
# 2) EETAx
# 3) VETA
# 4) VETAx

# 1) EETA
# compute E(ETA): expected value of latent variables (marginal over x)
# - if no eXo (and GAMMA):
#     E(ETA) = (I-B)^-1 ALPHA
# - if eXo and GAMMA:
#     E(ETA) = (I-B)^-1 ALPHA + (I-B)^-1 GAMMA mean.x
lav_lisrel_eeta <- function(MLIST = NULL, mean.x = NULL,
                            sample.mean = NULL,
                            ov.y.dummy.ov.idx = NULL,
                            ov.x.dummy.ov.idx = NULL,
                            ov.y.dummy.lv.idx = NULL,
                            ov.x.dummy.lv.idx = NULL) {
  BETA <- MLIST$beta
  GAMMA <- MLIST$gamma

  # ALPHA? (reconstruct, but no 'fix')
  ALPHA <- lav_lisrel_alpha0(
    MLIST = MLIST, sample.mean = sample.mean,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
  )

  # BETA?
  if (!is.null(BETA)) {
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
    # GAMMA?
    if (!is.null(GAMMA)) {
      eeta <- as.vector(IB.inv %*% ALPHA + IB.inv %*% GAMMA %*% mean.x)
    } else {
      eeta <- as.vector(IB.inv %*% ALPHA)
    }
  } else {
    # GAMMA?
    if (!is.null(GAMMA)) {
      eeta <- as.vector(ALPHA + GAMMA %*% mean.x)
    } else {
      eeta <- as.vector(ALPHA)
    }
  }

  eeta
}

# 2) EETAx
# compute E(ETA|x_i): conditional expected value of latent variable,
#                     given specific value of x_i
# - if no eXo (and GAMMA):
#     E(ETA) = (I-B)^-1 ALPHA
#     we return a matrix of size [nobs x nfac] replicating E(ETA)
# - if eXo and GAMMA:
#     E(ETA|x_i) = (I-B)^-1 ALPHA + (I-B)^-1 GAMMA x_i
#     we return  a matrix of size [nobs x nfac]
#
lav_lisrel_eetax <- function(MLIST = NULL, eXo = NULL, N = nrow(eXo),
                             sample.mean = NULL,
                             ov.y.dummy.ov.idx = NULL,
                             ov.x.dummy.ov.idx = NULL,
                             ov.y.dummy.lv.idx = NULL,
                             ov.x.dummy.lv.idx = NULL) {
  LAMBDA <- MLIST$lambda
  BETA <- MLIST$beta
  GAMMA <- MLIST$gamma
  nfac <- ncol(LAMBDA)
  # if eXo, N must be nrow(eXo)
  if (!is.null(eXo)) {
    N <- nrow(eXo)
  }

  # ALPHA?
  ALPHA <- lav_lisrel_alpha0(
    MLIST = MLIST, sample.mean = sample.mean,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
  )

  # construct [nobs x nfac] matrix (repeating ALPHA)
  EETA <- matrix(ALPHA, N, nfac, byrow = TRUE)

  # put back eXo values if dummy
  if (length(ov.x.dummy.lv.idx) > 0L) {
    EETA[, ov.x.dummy.lv.idx] <- eXo
  }

  # BETA?
  if (!is.null(BETA)) {
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
    EETA <- EETA %*% t(IB.inv)
  }

  # GAMMA?
  if (!is.null(GAMMA)) {
    if (!is.null(BETA)) {
      EETA <- EETA + eXo %*% t(IB.inv %*% GAMMA)
    } else {
      EETA <- EETA + eXo %*% t(GAMMA)
    }
  }

  EETA
}

# 3) VETA
# compute V(ETA): variances/covariances of latent variables
# - if no eXo (and GAMMA)
#     V(ETA) = (I-B)^-1 PSI (I-B)^-T
# - if eXo and GAMMA: (cfr lisrel submodel 3a with ksi=x)
#     V(ETA) = (I-B)^-1 [ GAMMA  cov.x t(GAMMA) + PSI] (I-B)^-T
lav_lisrel_veta <- function(MLIST = NULL) {
  LAMBDA <- MLIST$lambda
  nvar <- nrow(LAMBDA)
  PSI <- MLIST$psi
  THETA <- MLIST$theta
  BETA <- MLIST$beta
  GAMMA <- MLIST$gamma

  if (!is.null(GAMMA)) {
    COV.X <- MLIST$cov.x
    # we treat 'x' as 'ksi' in the LISREL model; cov.x is PHI
    PSI <- tcrossprod(GAMMA %*% COV.X, GAMMA) + PSI
  }

  # beta?
  if (is.null(BETA)) {
    VETA <- PSI
  } else {
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
    VETA <- tcrossprod(IB.inv %*% PSI, IB.inv)
  }

  VETA
}

# 4) VETAx
# compute V(ETA|x_i): variances/covariances of latent variables
#     V(ETA) = (I-B)^-1 PSI (I-B)^-T  + remove dummies
lav_lisrel_vetax <- function(MLIST = NULL, lv.dummy.idx = NULL) {
  PSI <- MLIST$psi
  BETA <- MLIST$beta

  # beta?
  if (is.null(BETA)) {
    VETA <- PSI
  } else {
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
    VETA <- tcrossprod(IB.inv %*% PSI, IB.inv)
  }

  # remove dummy lv?
  if (!is.null(lv.dummy.idx)) {
    VETA <- VETA[-lv.dummy.idx, -lv.dummy.idx, drop = FALSE]
  }

  VETA
}



# Y
# 1) EY
# 2) EYx
# 3) EYetax
# 4) VY
# 5) VYx
# 6) VYetax

# 1) EY
# compute E(Y): expected value of observed
# E(Y) = NU + LAMBDA %*% E(eta)
#      = NU + LAMBDA %*% (IB.inv %*% ALPHA) # no exo, no GAMMA
#      = NU + LAMBDA %*% (IB.inv %*% ALPHA + IB.inv %*% GAMMA %*% mean.x) # eXo
# if DELTA -> E(Y) = delta * E(Y)
#
# this is similar to lav_model_mu but:
# - we ALWAYS compute NU+ALPHA, even if meanstructure=FALSE
# - never used if GAMMA, since we then have categorical variables, and the
#   'part 1' structure contains the (thresholds +) intercepts, not
#   the means
lav_lisrel_ey <- function(MLIST = NULL, mean.x = NULL, sample.mean = NULL,
                          ov.y.dummy.ov.idx = NULL,
                          ov.x.dummy.ov.idx = NULL,
                          ov.y.dummy.lv.idx = NULL,
                          ov.x.dummy.lv.idx = NULL, delta = TRUE) {
  LAMBDA <- MLIST$lambda

  # get NU, but do not 'fix'
  NU <- lav_lisrel_nu0(
    MLIST = MLIST, sample.mean = sample.mean,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
  )

  # compute E(ETA)
  EETA <- lav_lisrel_eeta(
    MLIST = MLIST, sample.mean = sample.mean,
    mean.x = mean.x,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
  )

  # EY
  EY <- as.vector(NU) + as.vector(LAMBDA %*% EETA)

  # if delta, scale
  if (delta && !is.null(MLIST$delta)) {
    EY <- EY * as.vector(MLIST$delta)
  }

  EY
}

# 2) EYx
# compute E(Y|x_i): expected value of observed, conditional on x_i
# E(Y|x_i) = NU + LAMBDA %*% E(eta|x_i)

# - if no eXo (and GAMMA):
#     E(ETA|x_i) = (I-B)^-1 ALPHA
#     we return a matrix of size [nobs x nfac] replicating E(ETA)
# - if eXo and GAMMA:
#     E(ETA|x_i) = (I-B)^-1 ALPHA + (I-B)^-1 GAMMA x_i
#     we return  a matrix of size [nobs x nfac]
#
# - we ALWAYS compute NU+ALPHA, even if meanstructure=FALSE
# - never used if GAMMA, since we then have categorical variables, and the
#   'part 1' structure contains the (thresholds +) intercepts, not
#   the means
lav_lisrel_eyx <- function(MLIST = NULL,
                           eXo = NULL,
                           N = nrow(eXo),
                           sample.mean = NULL,
                           ov.y.dummy.ov.idx = NULL,
                           ov.x.dummy.ov.idx = NULL,
                           ov.y.dummy.lv.idx = NULL,
                           ov.x.dummy.lv.idx = NULL,
                           delta = TRUE) {
  LAMBDA <- MLIST$lambda

  # get NU, but do not 'fix'
  NU <- lav_lisrel_nu0(
    MLIST = MLIST,
    sample.mean = sample.mean,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
  )

  # compute E(ETA|x_i)
  EETAx <- lav_lisrel_eetax(
    MLIST = MLIST,
    eXo = eXo,
    N = N,
    sample.mean = sample.mean,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
  )

  # EYx
  EYx <- sweep(tcrossprod(EETAx, LAMBDA), 2L, STATS = NU, FUN = "+")

  # if delta, scale
  if (delta && !is.null(MLIST$delta)) {
    EYx <- sweep(EYx, 2L, STATS = MLIST$delta, FUN = "*")
  }

  EYx
}

# 3) EYetax
# compute E(Y|eta_i,x_i): conditional expected value of observed variable
#                         given specific value of eta_i AND x_i
#
# E(y*_i|eta_i, x_i) = NU + LAMBDA eta_i + KAPPA x_i
#
# where eta_i = predict(fit) = factor scores OR specific values for eta_i
# (as in GH integration)
#
# if nexo = 0, and eta_i is single row, YHAT is the same for each observation
# in this case, we return a single row, unless Nobs > 1L, in which case
# we return Nobs identical rows
#
# NOTE: we assume that any effect of x_i on eta_i has already been taken
#       care off

# categorical version
lav_lisrel_eyetax <- function(MLIST = NULL,
                              eXo = NULL,
                              ETA = NULL,
                              N = nrow(eXo),
                              sample.mean = NULL,
                              ov.y.dummy.ov.idx = NULL,
                              ov.x.dummy.ov.idx = NULL,
                              ov.y.dummy.lv.idx = NULL,
                              ov.x.dummy.lv.idx = NULL,
                              delta = TRUE) {
  LAMBDA <- MLIST$lambda
  BETA <- MLIST$beta
  if (!is.null(eXo)) {
    N <- nrow(eXo)
  } else if (!is.null(N)) {
    # nothing to do
  } else {
    N <- 1L
  }

  # create ETA matrix
  if (nrow(ETA) == 1L) {
    ETA <- matrix(ETA, N, ncol(ETA), byrow = TRUE)
  }

  # always augment ETA with 'dummy values' (0 for ov.y, eXo for ov.x)
  # ndummy <- length(c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx))
  # if(ndummy > 0L) {
  #    ETA2 <- cbind(ETA, matrix(0, N, ndummy))
  # } else {
  ETA2 <- ETA
  # }

  # only if we have dummy ov.y, we need to compute the 'yhat' values
  # beforehand
  if (length(ov.y.dummy.lv.idx) > 0L) {
    # insert eXo values
    if (length(ov.x.dummy.lv.idx) > 0L) {
      ETA2[, ov.x.dummy.lv.idx] <- eXo
    }
    # zero ov.y values
    if (length(ov.y.dummy.lv.idx) > 0L) {
      ETA2[, ov.y.dummy.lv.idx] <- 0
    }

    # ALPHA? (reconstruct, but no 'fix')
    ALPHA <- lav_lisrel_alpha0(
      MLIST = MLIST, sample.mean = sample.mean,
      ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
      ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
      ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
      ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
    )
    # BETA?
    if (!is.null(BETA)) {
      ETA2 <- sweep(tcrossprod(ETA2, BETA), 2L, STATS = ALPHA, FUN = "+")
    } else {
      ETA2 <- sweep(ETA2, 2L, STATS = ALPHA, FUN = "+")
    }

    # put back eXo values
    if (length(ov.x.dummy.lv.idx) > 0L) {
      ETA2[, ov.x.dummy.lv.idx] <- eXo
    }

    # put back ETA values for the 'real' latent variables
    dummy.idx <- c(ov.x.dummy.lv.idx, ov.y.dummy.lv.idx)
    if (length(dummy.idx) > 0L) {
      lv.regular.idx <- seq_len(min(dummy.idx) - 1L)
      ETA2[, lv.regular.idx] <- ETA[, lv.regular.idx, drop = FALSE]
    }
  }

  # get NU, but do not 'fix'
  NU <- lav_lisrel_nu0(
    MLIST = MLIST,
    sample.mean = sample.mean,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
  )

  # EYetax
  EYetax <- sweep(tcrossprod(ETA2, LAMBDA), 2L, STATS = NU, FUN = "+")

  # if delta, scale
  if (delta && !is.null(MLIST$delta)) {
    EYetax <- sweep(EYetax, 2L, STATS = MLIST$delta, FUN = "*")
  }

  EYetax
}

# unconditional version
lav_lisrel_eyetax2 <- function(MLIST = NULL,
                               ETA = NULL,
                               sample.mean = NULL,
                               ov.y.dummy.ov.idx = NULL,
                               ov.x.dummy.ov.idx = NULL,
                               ov.y.dummy.lv.idx = NULL,
                               ov.x.dummy.lv.idx = NULL,
                               delta = TRUE) {
  LAMBDA <- MLIST$lambda
  BETA <- MLIST$beta


  # only if we have dummy ov.y, we need to compute the 'yhat' values
  # beforehand, and impute them in ETA[,ov.y]
  if (length(ov.y.dummy.lv.idx) > 0L) {
    # ALPHA? (reconstruct, but no 'fix')
    ALPHA <- lav_lisrel_alpha0(
      MLIST = MLIST, sample.mean = sample.mean,
      ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
      ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
      ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
      ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
    )

    # keep all, but ov.y values
    OV.NOY <- ETA[, -ov.y.dummy.lv.idx, drop = FALSE]
    # ov.y rows, non-ov.y cols
    BETAY <- BETA[ov.y.dummy.lv.idx, -ov.y.dummy.lv.idx, drop = FALSE]
    # ov.y intercepts
    ALPHAY <- ALPHA[ov.y.dummy.lv.idx, , drop = FALSE]

    # impute ov.y values in ETA
    ETA[, ov.y.dummy.lv.idx] <-
      sweep(tcrossprod(OV.NOY, BETAY), 2L, STATS = ALPHAY, FUN = "+")
  }

  # get NU, but do not 'fix'
  NU <- lav_lisrel_nu0(
    MLIST = MLIST,
    sample.mean = sample.mean,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
  )

  # EYetax
  EYetax <- sweep(tcrossprod(ETA, LAMBDA), 2L, STATS = NU, FUN = "+")

  # if delta, scale
  if (delta && !is.null(MLIST$delta)) {
    EYetax <- sweep(EYetax, 2L, STATS = MLIST$delta, FUN = "*")
  }

  EYetax
}

# unconditional version
lav_lisrel_eyetax3 <- function(MLIST = NULL,
                               ETA = NULL,
                               sample.mean = NULL,
                               mean.x = NULL,
                               ov.y.dummy.ov.idx = NULL,
                               ov.x.dummy.ov.idx = NULL,
                               ov.y.dummy.lv.idx = NULL,
                               ov.x.dummy.lv.idx = NULL,
                               delta = TRUE) {
  LAMBDA <- MLIST$lambda

  # special case: empty lambda
  if (ncol(LAMBDA) == 0L) {
    return(matrix(sample.mean,
      nrow(ETA), length(sample.mean),
      byrow = TRUE
    ))
  }

  # lv idx
  dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx)
  if (length(dummy.idx) > 0L) {
    nondummy.idx <- seq_len(min(dummy.idx) - 1L)
  } else {
    nondummy.idx <- seq_len(ncol(MLIST$lambda))
  }

  # beta?
  if (is.null(MLIST$beta) || length(ov.y.dummy.lv.idx) == 0L ||
    length(nondummy.idx) == 0L) {
    LAMBDA..IB.inv <- LAMBDA
  } else {
    # only keep those columns of BETA that correspond to the
    # the `regular' latent variables
    # (ie. ignore the structural part altogether)
    MLIST2 <- MLIST
    MLIST2$beta[, dummy.idx] <- 0
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST2)
    LAMBDA..IB.inv <- LAMBDA %*% IB.inv
  }

  # compute model-implied means
  EY <- lav_lisrel_ey(
    MLIST = MLIST, mean.x = mean.x,
    sample.mean = sample.mean,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
  )

  EETA <- lav_lisrel_eeta(
    MLIST = MLIST, sample.mean = sample.mean,
    mean.x = mean.x,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
  )

  # center regular lv only
  ETA[, nondummy.idx] <- sweep(ETA[, nondummy.idx, drop = FALSE], 2L,
    STATS = EETA[nondummy.idx], FUN = "-"
  )

  # project from lv to ov, if we have any lv
  if (length(nondummy.idx) > 0) {
    EYetax <- sweep(
      tcrossprod(
        ETA[, nondummy.idx, drop = FALSE],
        LAMBDA..IB.inv[, nondummy.idx, drop = FALSE]
      ),
      2L,
      STATS = EY, FUN = "+"
    )
  } else {
    EYetax <- ETA
  }

  # put back eXo variables
  if (length(ov.x.dummy.lv.idx) > 0L) {
    EYetax[, ov.x.dummy.ov.idx] <- ETA[, ov.x.dummy.lv.idx, drop = FALSE]
  }

  # if delta, scale
  if (delta && !is.null(MLIST$delta)) {
    EYetax <- sweep(EYetax, 2L, STATS = MLIST$delta, FUN = "*")
  }

  EYetax
}

# 4) VY
# compute the *un*conditional variance/covariance of y: V(Y) or V(Y*)
# 'unconditional' model-implied (co)variances
#  - same as Sigma.hat if all Y are continuous
#  - diagonal is 1.0 (or delta^2) if categorical
#  - if also Gamma, cov.x is used (only if conditional.x)
#    only in THIS case, VY is different from diag(VYx)
#
# V(Y) = LAMBDA V(ETA) t(LAMBDA) + THETA
lav_lisrel_vy <- function(MLIST = NULL) {
  LAMBDA <- MLIST$lambda
  THETA <- MLIST$theta

  VETA <- lav_lisrel_veta(MLIST = MLIST)
  VY <- tcrossprod(LAMBDA %*% VETA, LAMBDA) + THETA
  VY
}

# 5) VYx
# compute V(Y*|x_i) == model-implied covariance matrix
# this equals V(Y*) if no (explicit) eXo no GAMMA
#
# in >0.6-20: special treatment for composites
#
lav_lisrel_sigma <- function(MLIST = NULL, delta = TRUE) {
  LAMBDA <- MLIST$lambda
  nvar <- nrow(LAMBDA)
  PSI <- MLIST$psi
  THETA <- MLIST$theta
  BETA <- MLIST$beta
  WMAT <- MLIST$wmat

  # standard: no composites
  if (is.null(WMAT)) {
    # beta?
    if (is.null(BETA)) {
      LAMBDA..IB.inv <- LAMBDA
    } else {
      IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
      LAMBDA..IB.inv <- LAMBDA %*% IB.inv
    }
    # compute V(Y*|x_i)
    VYx <- tcrossprod(LAMBDA..IB.inv %*% PSI, LAMBDA..IB.inv) + THETA

  # composites, or mix of composites and latent variables
  } else {
    # - first join LAMBDA and WMAT
    # - create 'T' matrix: - identity for regular lv's,
    #                      - THETA block-diagonal for composites
    # - create C_0: VETA, but zero diagonal elements for composites
    cov.idx <- which(apply(LAMBDA, 1L,
                           function(x) sum(x == 0) == ncol(LAMBDA)))
    clv.idx <- which(apply(LAMBDA, 2L,
                           function(x) sum(x == 0) == nrow(LAMBDA)))
    # regular latent variables
    rlv.idx <- seq_len(ncol(LAMBDA))[-clv.idx]

    # combine LAMBDA and WMAT
    LW <- LAMBDA + WMAT

    Tmat <- diag(nrow(LAMBDA))
    Tmat[cov.idx, cov.idx] <- THETA[cov.idx, cov.idx]
    wtw <- t(LW[,clv.idx, drop = FALSE]) %*% Tmat %*% LW[,clv.idx, drop = FALSE]
    wtw.inv <- solve(wtw)
    WTW.inv <- diag(ncol(LAMBDA))
    WTW.inv[clv.idx, clv.idx] <- wtw.inv

    if (is.null(BETA)) {
      IB.inv <- diag(nrow(PSI))
    } else {
      IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
    }
    VETA <- IB.inv %*% PSI %*% t(IB.inv)
    C0 <- VETA; diag(C0)[clv.idx] <- 0

    VYx <- Tmat %*% LW %*% WTW.inv %*% C0 %*% t(WTW.inv) %*% t(LW) %*% Tmat + THETA
  }

  # if delta, scale
  if (delta && !is.null(MLIST$delta)) {
    DELTA <- diag(MLIST$delta[, 1L], nrow = nvar, ncol = nvar)
    VYx <- DELTA %*% VYx %*% DELTA
  }

  VYx
}

# 6) VYetax
# V(Y | eta_i, x_i) = THETA
lav_lisrel_vyetax <- function(MLIST = NULL, delta = TRUE) {
  VYetax <- MLIST$theta
  nvar <- nrow(MLIST$theta)

  # if delta, scale
  if (delta && !is.null(MLIST$delta)) {
    DELTA <- diag(MLIST$delta[, 1L], nrow = nvar, ncol = nvar)
    VYetax <- DELTA %*% VYetax %*% DELTA
  }

  VYetax
}


### compute model-implied sample statistics
#
# 1) MuHat (similar to EY, but continuous only)
# 2) TH
# 3) PI
# 4) SigmaHat == VYx

# compute MuHat for a single block/group; only for the continuous case (no eXo)
#
# this is a special case of E(Y) where
# - we have no (explicit) eXogenous variables
# - only continuous
lav_lisrel_mu<- function(MLIST = NULL) {
  NU <- MLIST$nu
  ALPHA <- MLIST$alpha
  LAMBDA <- MLIST$lambda
  BETA <- MLIST$beta

  # shortcut
  if (is.null(ALPHA) || is.null(NU)) {
    return(matrix(0, nrow(LAMBDA), 1L))
  }

  # beta?
  if (is.null(BETA)) {
    LAMBDA..IB.inv <- LAMBDA
  } else {
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
    LAMBDA..IB.inv <- LAMBDA %*% IB.inv
  }

  # compute Mu Hat
  Mu.hat <- NU + LAMBDA..IB.inv %*% ALPHA

  Mu.hat
}

# compute TH for a single block/group
lav_lisrel_th <- function(MLIST = NULL, th.idx = NULL, delta = TRUE) {
  LAMBDA <- MLIST$lambda
  nvar <- nrow(LAMBDA)
  nfac <- ncol(LAMBDA)
  BETA <- MLIST$beta
  TAU <- MLIST$tau
  nth <- nrow(TAU)

  # missing alpha
  if (is.null(MLIST$alpha)) {
    ALPHA <- matrix(0, nfac, 1L)
  } else {
    ALPHA <- MLIST$alpha
  }

  # missing nu
  if (is.null(MLIST$nu)) {
    NU <- matrix(0, nvar, 1L)
  } else {
    NU <- MLIST$nu
  }

  if (is.null(th.idx)) {
    th.idx <- seq_len(nth)
    nlev <- rep(1L, nvar)
    K_nu <- diag(nvar)
  } else {
    nlev <- tabulate(th.idx, nbins = nvar)
    nlev[nlev == 0L] <- 1L
    K_nu <- matrix(0, sum(nlev), nvar)
    K_nu[cbind(seq_len(sum(nlev)), rep(seq_len(nvar), times = nlev))] <- 1.0
  }

  # shortcut
  if (is.null(TAU)) {
    return(matrix(0, length(th.idx), 1L))
  }

  # beta?
  if (is.null(BETA)) {
    LAMBDA..IB.inv <- LAMBDA
  } else {
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
    LAMBDA..IB.inv <- LAMBDA %*% IB.inv
  }

  # compute pi0
  pi0 <- NU + LAMBDA..IB.inv %*% ALPHA

  # interleave th's with zeros where we have numeric variables
  th <- numeric(length(th.idx))
  th[th.idx > 0L] <- TAU[, 1L]

  # compute TH
  TH <- th - (K_nu %*% pi0)

  # if delta, scale
  if (delta && !is.null(MLIST$delta)) {
    DELTA.diag <- MLIST$delta[, 1L]
    DELTA.star.diag <- rep(DELTA.diag, times = nlev)
    TH <- TH * DELTA.star.diag
  }

  as.vector(TH)
}

# compute PI for a single block/group
lav_lisrel_pi <- function(MLIST = NULL, delta = TRUE) {
  LAMBDA <- MLIST$lambda
  BETA <- MLIST$beta
  GAMMA <- MLIST$gamma

  # shortcut
  if (is.null(GAMMA)) {
    return(matrix(0, nrow(LAMBDA), 0L))
  }

  # beta?
  if (is.null(BETA)) {
    LAMBDA..IB.inv <- LAMBDA
  } else {
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
    LAMBDA..IB.inv <- LAMBDA %*% IB.inv
  }

  # compute PI
  PI <- LAMBDA..IB.inv %*% GAMMA

  # if delta, scale
  if (delta && !is.null(MLIST$delta)) {
    DELTA.diag <- MLIST$delta[, 1L]
    PI <- PI * DELTA.diag
  }

  PI
}

lav_lisrel_lambda <- function(MLIST = NULL,
                              ov.y.dummy.ov.idx = NULL,
                              ov.x.dummy.ov.idx = NULL,
                              ov.y.dummy.lv.idx = NULL,
                              ov.x.dummy.lv.idx = NULL,
                              remove.dummy.lv = FALSE) {
  lv.dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx)

  # fix LAMBDA
  LAMBDA <- MLIST$lambda
  if (length(ov.y.dummy.ov.idx) > 0L && !is.null(MLIST$beta)) {
    LAMBDA[ov.y.dummy.ov.idx, ] <- MLIST$beta[ov.y.dummy.lv.idx, ]
  }

  # remove dummy lv?
  if (remove.dummy.lv && length(lv.dummy.idx) > 0L) {
    LAMBDA <- LAMBDA[, -lv.dummy.idx, drop = FALSE]
  }

  LAMBDA
}

lav_lisrel_theta <- function(MLIST = NULL,
                             ov.y.dummy.ov.idx = NULL,
                             ov.x.dummy.ov.idx = NULL,
                             ov.y.dummy.lv.idx = NULL,
                             ov.x.dummy.lv.idx = NULL) {
  ov.dummy.idx <- c(ov.y.dummy.ov.idx, ov.x.dummy.ov.idx)
  lv.dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx)

  # fix THETA
  THETA <- MLIST$theta
  if (length(ov.dummy.idx) > 0L) {
    THETA[ov.dummy.idx, ov.dummy.idx] <-
      MLIST$psi[lv.dummy.idx, lv.dummy.idx]
  }

  THETA
}

lav_lisrel_nu <- function(MLIST = NULL,
                             sample.mean = sample.mean,
                             ov.y.dummy.ov.idx = NULL,
                             ov.x.dummy.ov.idx = NULL,
                             ov.y.dummy.lv.idx = NULL,
                             ov.x.dummy.lv.idx = NULL) {
  # get NU, but do not 'fix'
  NU <- lav_lisrel_nu0(
    MLIST = MLIST, sample.mean = sample.mean,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
  )

  # ALPHA? (reconstruct, but no 'fix')
  ALPHA <- lav_lisrel_alpha0(
    MLIST = MLIST, sample.mean = sample.mean,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
  )

  ov.dummy.idx <- c(ov.y.dummy.ov.idx, ov.x.dummy.ov.idx)
  lv.dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx)

  # fix NU
  if (length(ov.dummy.idx) > 0L) {
    NU[ov.dummy.idx, 1] <- ALPHA[lv.dummy.idx, 1]
  }

  NU
}

# compute IB.inv
lav_lisrel_ibinv  <- function(MLIST = NULL) {
  BETA <- MLIST$beta
  nr <- nrow(MLIST$psi)

  if (!is.null(BETA)) {
    tmp <- -BETA
    tmp[lav_matrix_diag_idx(nr)] <- 1
    IB.inv <- solve(tmp)
  } else {
    IB.inv <- diag(nr)
  }

  IB.inv
}

# only if ALPHA=NULL but we need it anyway
# we 'reconstruct' ALPHA here (including dummy entries), no fixing
#
# without any dummy variables, this is just the zero vector
# but if we have dummy variables, we need to fill in their values
#
#
lav_lisrel_alpha0 <- function(MLIST = NULL, sample.mean = NULL,
                              ov.y.dummy.ov.idx = NULL,
                              ov.x.dummy.ov.idx = NULL,
                              ov.y.dummy.lv.idx = NULL,
                              ov.x.dummy.lv.idx = NULL) {
  if (!is.null(MLIST$alpha)) {
    return(MLIST$alpha)
  }

  LAMBDA <- MLIST$lambda
  nfac <- ncol(LAMBDA)

  ov.dummy.idx <- c(ov.y.dummy.ov.idx, ov.x.dummy.ov.idx)
  lv.dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx)

  if (length(ov.dummy.idx) > 0L) {
    ALPHA <- matrix(0, nfac, 1L)
    # Note: instead of sample.mean, we need 'intercepts'
    # sample.mean = NU + LAMBDA..IB.inv %*% ALPHA
    # so,
    # solve(LAMBDA..IB.inv) %*% (sample.mean - NU) = ALPHA
    # where
    # - LAMBDA..IB.inv only contains 'dummy' variables, and is square
    # - NU elements are not needed (since not in ov.dummy.idx)
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
    LAMBDA..IB.inv <- LAMBDA %*% IB.inv
    LAMBDA..IB.inv.dummy <- LAMBDA..IB.inv[ov.dummy.idx, lv.dummy.idx]
    ALPHA[lv.dummy.idx] <-
      solve(LAMBDA..IB.inv.dummy, sample.mean[ov.dummy.idx])
  } else {
    ALPHA <- matrix(0, nfac, 1L)
  }

  ALPHA
}

# only if NU=NULL but we need it anyway
#
# since we have no meanstructure, we can assume NU is unrestricted
# and contains either:
#     1) the sample means (if not eXo)
#     2) the intercepts, if we have exogenous covariates
#        since sample.mean = NU + LAMBDA %*% E(eta)
#        we have NU = sample.mean - LAMBDA %*% E(eta)
lav_lisrel_nu0 <- function(MLIST = NULL, sample.mean = NULL,
                           ov.y.dummy.ov.idx = NULL,
                           ov.x.dummy.ov.idx = NULL,
                           ov.y.dummy.lv.idx = NULL,
                           ov.x.dummy.lv.idx = NULL) {
  if (!is.null(MLIST$nu)) {
    return(MLIST$nu)
  }

  # if nexo > 0, substract lambda %*% EETA
  if (length(ov.x.dummy.ov.idx) > 0L) {
    EETA <- lav_lisrel_eeta(MLIST,
      mean.x = NULL,
      sample.mean = sample.mean,
      ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
      ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
      ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
      ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
    )

    # 'regress' NU on X
    NU <- sample.mean - MLIST$lambda %*% EETA

    # just to make sure we have exact zeroes for all dummies
    NU[c(ov.y.dummy.ov.idx, ov.x.dummy.ov.idx)] <- 0
  } else {
    # unrestricted mean
    NU <- sample.mean
  }

  NU
}

lav_lisrel_kappa <- function(MLIST = NULL,
                             ov.y.dummy.ov.idx = NULL,
                             ov.x.dummy.ov.idx = NULL,
                             ov.y.dummy.lv.idx = NULL,
                             ov.x.dummy.lv.idx = NULL,
                             nexo = NULL) {
  nvar <- nrow(MLIST$lambda)
  if (!is.null(MLIST$gamma)) {
    this.nexo <- ncol(MLIST$gamma)
  } else if (!is.null(nexo)) {
    this.nexo <- nexo
  } else {
    lav_msg_stop(gettext("nexo not known"))
  }

  # create KAPPA
  KAPPA <- matrix(0, nvar, this.nexo)
  if (!is.null(MLIST$gamma)) {
    KAPPA[ov.y.dummy.ov.idx, ] <-
      MLIST$gamma[ov.y.dummy.lv.idx, , drop = FALSE]
  } else if (length(ov.x.dummy.ov.idx) > 0L) {
    KAPPA[ov.y.dummy.ov.idx, ] <-
      MLIST$beta[ov.y.dummy.lv.idx,
        ov.x.dummy.lv.idx,
        drop = FALSE
      ]
  }

  KAPPA
}


# old version of computeEYetax (using 'fixing')
lav_lisrel_eyetax_old <- function(MLIST = NULL, eXo = NULL, ETA = NULL,
                                  sample.mean = NULL,
                                  ov.y.dummy.ov.idx = NULL,
                                  ov.x.dummy.ov.idx = NULL,
                                  ov.y.dummy.lv.idx = NULL,
                                  ov.x.dummy.lv.idx = NULL,
                                  Nobs = 1L) {
  LAMBDA <- MLIST$lambda
  nvar <- nrow(LAMBDA)
  nfac <- ncol(LAMBDA)
  lv.dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx)
  ov.dummy.idx <- c(ov.y.dummy.ov.idx, ov.x.dummy.ov.idx)

  # exogenous variables?
  if (is.null(eXo)) {
    nexo <- 0L
  } else {
    nexo <- ncol(eXo)
    # check ETA rows
    if (!(nrow(ETA) == 1L || nrow(ETA) == nrow(eXo))) {
      lav_msg_stop(gettext("!(nrow(ETA) == 1L || nrow(ETA) == nrow(eXo))"))
    }
  }

  # get NU
  NU <- lav_lisrel_nu0(
    MLIST = MLIST, sample.mean = sample.mean,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
  )

  # ALPHA? (reconstruct, but no 'fix')
  ALPHA <- lav_lisrel_alpha0(
    MLIST = MLIST, sample.mean = sample.mean,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
  )

  # fix NU
  if (length(lv.dummy.idx) > 0L) {
    NU[ov.dummy.idx, 1L] <- ALPHA[lv.dummy.idx, 1L]
  }

  # fix LAMBDA (remove dummies) ## FIXME -- needed?
  LAMBDA <- MLIST$lambda
  if (length(lv.dummy.idx) > 0L) {
    LAMBDA <- LAMBDA[, -lv.dummy.idx, drop = FALSE]
    nfac <- ncol(LAMBDA)
    LAMBDA[ov.y.dummy.ov.idx, ] <-
      MLIST$beta[ov.y.dummy.lv.idx, seq_len(nfac), drop = FALSE]
  }

  # compute YHAT
  YHAT <- sweep(ETA %*% t(LAMBDA), MARGIN = 2, NU, "+")

  # Kappa + eXo?
  # note: Kappa elements are either in Gamma or in Beta
  if (nexo > 0L) {
    # create KAPPA
    KAPPA <- lav_lisrel_kappa(
      MLIST = MLIST,
      ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
      ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
      ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
      ov.x.dummy.lv.idx = ov.x.dummy.lv.idx,
      nexo = nexo
    )

    # expand YHAT if ETA only has 1 row
    if (nrow(YHAT) == 1L) {
      YHAT <- sweep(eXo %*% t(KAPPA), MARGIN = 2, STATS = YHAT, FUN = "+")
    } else {
      # add fixed part
      YHAT <- YHAT + (eXo %*% t(KAPPA))
    }

    # put back eXo
    if (length(ov.x.dummy.ov.idx) > 0L) {
      YHAT[, ov.x.dummy.ov.idx] <- eXo
    }
  } else {
    # duplicate?
    if (is.numeric(Nobs) && Nobs > 1L && nrow(YHAT) == 1L) {
      YHAT <- matrix(YHAT, Nobs, nvar, byrow = TRUE)
      # YHAT <- YHAT[ rep(1L, Nobs), ]
    }
  }

  # delta?
  # FIXME: not used here?
  # if(!is.null(DELTA)) {
  #    YHAT <- sweep(YHAT, MARGIN=2, DELTA, "*")
  # }

  YHAT
}


# deal with 'dummy' OV.X latent variables
# create additional matrices (eg GAMMA), and resize
# remove all ov.x related entries
lav_lisrel_lisrelx <- function(MLIST = NULL,
                         ov.x.dummy.ov.idx = NULL,
                         ov.x.dummy.lv.idx = NULL) {
  lv.idx <- ov.x.dummy.lv.idx
  ov.idx <- ov.x.dummy.ov.idx
  if (length(lv.idx) == 0L) {
    return(MLIST)
  }
  if (!is.null(MLIST$gamma)) {
    nexo <- ncol(MLIST$gamma)
  } else {
    nexo <- length(ov.x.dummy.ov.idx)
  }
  nvar <- nrow(MLIST$lambda)
  nfac <- ncol(MLIST$lambda) - length(lv.idx)

  # copy
  MLISTX <- MLIST

  # fix LAMBDA:
  # - remove all ov.x related columns/rows
  MLISTX$lambda <- MLIST$lambda[-ov.idx, -lv.idx, drop = FALSE]

  # fix THETA:
  # - remove ov.x related columns/rows
  MLISTX$theta <- MLIST$theta[-ov.idx, -ov.idx, drop = FALSE]

  # fix PSI:
  # - remove ov.x related columns/rows
  MLISTX$psi <- MLIST$psi[-lv.idx, -lv.idx, drop = FALSE]

  # create GAMMA
  if (length(ov.x.dummy.lv.idx) > 0L) {
    MLISTX$gamma <- MLIST$beta[-lv.idx, lv.idx, drop = FALSE]
  }

  # fix BETA (remove if empty)
  if (!is.null(MLIST$beta)) {
    MLISTX$beta <- MLIST$beta[-lv.idx, -lv.idx, drop = FALSE]
    if (ncol(MLISTX$beta) == 0L) MLISTX$beta <- NULL
  }

  # fix NU
  if (!is.null(MLIST$nu)) {
    MLISTX$nu <- MLIST$nu[-ov.idx, 1L, drop = FALSE]
  }

  # fix ALPHA
  if (!is.null(MLIST$alpha)) {
    MLISTX$alpha <- MLIST$alpha[-lv.idx, 1L, drop = FALSE]
  }

  MLISTX
}


# create MLIST from MLISTX
lav_lisrelx_lisrel <- function(MLISTX = NULL,
                         ov.x.dummy.ov.idx = NULL,
                         ov.x.dummy.lv.idx = NULL,
                         mean.x = NULL,
                         cov.x = NULL) {
  lv.idx <- ov.x.dummy.lv.idx
  ndum <- length(lv.idx)
  ov.idx <- ov.x.dummy.ov.idx
  if (length(lv.idx) == 0L) {
    return(MLISTX)
  }
  stopifnot(!is.null(cov.x), !is.null(mean.x))
  nvar <- nrow(MLISTX$lambda)
  nfac <- ncol(MLISTX$lambda)

  # copy
  MLIST <- MLISTX

  # resize matrices
  MLIST$lambda <- rbind(
    cbind(MLISTX$lambda, matrix(0, nvar, ndum)),
    matrix(0, ndum, nfac + ndum)
  )
  MLIST$psi <- rbind(
    cbind(MLISTX$psi, matrix(0, nfac, ndum)),
    matrix(0, ndum, nfac + ndum)
  )
  MLIST$theta <- rbind(
    cbind(MLISTX$theta, matrix(0, nvar, ndum)),
    matrix(0, ndum, nvar + ndum)
  )
  if (!is.null(MLISTX$beta)) {
    MLIST$beta <- rbind(
      cbind(MLISTX$beta, matrix(0, nfac, ndum)),
      matrix(0, ndum, nfac + ndum)
    )
  }
  if (!is.null(MLISTX$alpha)) {
    MLIST$alpha <- rbind(MLISTX$alpha, matrix(0, ndum, 1))
  }
  if (!is.null(MLISTX$nu)) {
    MLIST$nu <- rbind(MLISTX$nu, matrix(0, ndum, 1))
  }

  # fix LAMBDA:
  # - add columns for all dummy latent variables
  MLIST$lambda[cbind(ov.idx, lv.idx)] <- 1

  # fix PSI
  # - move cov.x elements to PSI
  MLIST$psi[lv.idx, lv.idx] <- cov.x

  # move (ov.x.dummy elements of) GAMMA to BETA
  MLIST$beta[seq_len(nfac), ov.x.dummy.lv.idx] <- MLISTX$gamma
  MLIST$gamma <- NULL

  # fix ALPHA
  if (!is.null(MLIST$alpha)) {
    MLIST$alpha[lv.idx] <- mean.x
  }

  MLIST
}

# set (total/residual) variances of composites
# and while we at it, also set intercepts of composites
lav_lisrel_composites_variances<- function(MLIST = NULL,
                                           tol = .Machine$double.eps,
                                           debug = FALSE) {
  LAMBDA <- MLIST$lambda
  BETA   <- MLIST$beta
  PSI    <- MLIST$psi
  WMAT   <- MLIST$wmat
  THETA  <- MLIST$theta

  # std.lv or not?
  marker.idx <- lav_utils_get_marker(MLIST$wmat)
  std.lv <- FALSE
  if (all(is.na(marker.idx))) {
    std.lv <- TRUE
  }

  # housekeeping
  ovc.idx <- which(apply(LAMBDA, 1L,
                         function(x) sum(x == 0) == ncol(LAMBDA)))
  lvc.idx <- which(apply(LAMBDA, 2L,
                         function(x) sum(x == 0) == nrow(LAMBDA)))
  lvc.flag <- logical(nrow(PSI))
  lvc.flag[lvc.idx] <- TRUE
  Tmat <- diag(nrow(LAMBDA))
  Tmat[ovc.idx, ovc.idx] <- MLIST$theta[ovc.idx, ovc.idx]

  if (std.lv) {
    target.psi <- rep(1, ncol(WMAT))
  } else {
    # total variances composites
    target.psi <- diag(t(WMAT) %*% Tmat %*% WMAT)
  }
  # fill in PSI element for non-composites
  target.psi[!lvc.flag] <- diag(PSI)[!lvc.flag]

  # initial values (including exogenous variances)
  diag(PSI) <- target.psi

  # no regressions
  if (is.null(BETA)) {
    # store PSI
    MLIST$psi <- PSI

    return(MLIST)
  }

  # set (residual) variances in psi
  abs.beta <- abs(MLIST$beta)
  x.idx <- which(apply(abs.beta, 1L, sum) == 0 & lvc.flag)
  y.idx <- which(apply(abs.beta, 1L, sum) != 0 & lvc.flag)

  nr <- nrow(BETA)
  IB <- -BETA
  IB[lav_matrix_diag_idx(nr)] <- 1
  IB.inv <- solve(IB)


  # check if IB is acyclic
  if (det(IB) != 1) {
    # damn, we have an cyclic model; use nlminb()
    PSI <- lav_mlist_target_psi(IB.inv = IB.inv, PSI = PSI,
                                    target.psi = target.psi, y.idx = y.idx)
  } else {
    # for an acyclic model, we should be able to find the
    # residual analytically; simply by computing the model-based
    # total variances of the RHS of each regression, and set the
    # residual of the y variable so that it is exactly equal to unity
    # (yes, this will result in negative resdidual variances if needed)

    # ideally, we first sort the variables 'in topological order'; then
    # we need only one run; but here we are somewhat lazy, and we
    # use a few runs, each time setting more variables right

    # get ancestors list for each node/variable
    ancestors <- lav_graph_get_ancestors(BETA)

    # for each y variable, compute IB.inv %*% psi %*% t(IB.inv), without y
    ny <- length(y.idx)
    max_rep <- ny * 4
    for(rep in seq_len(max_rep)) {
      if (debug) {
        cat("rep = ", rep, "\n")
      }
      # check current diagonal
      current.diag <- diag(IB.inv %*% PSI %*% t(IB.inv))
      if (debug) {
        cat("target.psi   = ", target.psi[y.idx], "\n")
        cat("current.diag = ", current.diag[y.idx], "\n")
      }
      if (all(abs(current.diag[y.idx] - target.psi[y.idx]) < tol)) {
        # we are done, bail out
        break
      }
      for (i in seq_len(ny)) {
        this.y.idx <- y.idx[i]
        this.x.idx <- ancestors[[this.y.idx]]
        IB.inv.y <- IB.inv[this.y.idx, this.x.idx, drop = FALSE]
        PSI.x <- PSI[this.x.idx, this.x.idx, drop = FALSE]
        var.y <- drop(IB.inv.y %*% PSI.x %*% t(IB.inv.y))
        PSI[this.y.idx, this.y.idx] <- target.psi[this.y.idx] - var.y
      }
    }

    # final check?
    current.diag <- diag(IB.inv %*% PSI %*% t(IB.inv))
    if (debug) {
      cat("final current.diag = ", current.diag[y.idx], "\n")
    }
    # don't be too strict here
    if (any(abs(current.diag[y.idx] - target.psi[y.idx]) > sqrt(tol))) {
      # as a last resort, use optimization
      PSI <- lav_mlist_target_psi(IB.inv = IB.inv, PSI = PSI,
                                      target.psi = target.psi, y.idx = y.idx)
    }

  } # acyclic

  # store PSI
  MLIST$psi <- PSI

  # fix composite mean (if needed)
  if (!is.null(MLIST$alpha)) {
    tmp <- t(WMAT) %*% MLIST$nu
    MLIST$alpha[lvc.idx, 1L] <- tmp[lvc.idx, 1L]
  }

  MLIST
}

# if DELTA parameterization, compute residual elements (in theta, or psi)
# - typically for (endogenous) observed *categorical* variables only
# - but could also be all (endogenous) observed variables, if correlation = TRUE
# - or all (endogenous) latent and observed variables, if ov.only = FALSE
#
# new version YR 29 Oct 2024: try harder for psi elements (but this only works
#                             for acyclic models)
#             YR 01 Noc 2024: for non-acyclic models: use optimization
lav_lisrel_residual_variances <- function(MLIST = NULL,
                                          num.idx = NULL,
                                          ov.y.dummy.ov.idx = NULL,
                                          ov.y.dummy.lv.idx = NULL,
                                          ov.only = TRUE,
                                          tol = .Machine$double.eps,
                                          debug = FALSE) {
  BETA <- MLIST$beta
  PSI  <- MLIST$psi
  if (is.null(MLIST$delta)) {
    delta <- rep(1, nrow(MLIST$lambda))
  } else {
    delta <- MLIST$delta
  }

  # remove num.idx from ov.y.dummy.*
  if (length(num.idx) > 0L && length(ov.y.dummy.ov.idx) > 0L) {
    n.idx <- which(ov.y.dummy.ov.idx %in% num.idx)
    if (length(n.idx) > 0L) {
      ov.y.dummy.ov.idx <- ov.y.dummy.ov.idx[-n.idx]
      ov.y.dummy.lv.idx <- ov.y.dummy.lv.idx[-n.idx]
    }
  }

  # if delta, the target may not be unity, but DELTA^(-2)
  target.all <- 1/(delta * delta) # often the unit vector
  target.psi <- rep(1, nrow(PSI))
  if (length(ov.y.dummy.ov.idx) > 0L) {
    target.psi[ov.y.dummy.lv.idx] <- target.all[ov.y.dummy.ov.idx]
  }

  # phase 1: set (residual) variances in psi
  if (!is.null(BETA) && length(ov.y.dummy.ov.idx) > 0L) {
    abs.beta <- abs(MLIST$beta)
    x.idx <- which(apply(abs.beta, 1L, sum) == 0)
    if (ov.only) {
      y.idx <- ov.y.dummy.lv.idx
      # remove x.idx elements (fixed.x = FALSE)
      if (any(y.idx %in% x.idx)) {
        y.idx <- y.idx[-which(y.idx %in% x.idx)]
      }
    } else {
      y.idx <- which(apply(abs.beta, 1L, sum) != 0)
    }

    nr <- nrow(BETA)
    IB <- -BETA
    IB[lav_matrix_diag_idx(nr)] <- 1
    IB.inv <- solve(IB)


    # check if IB is acyclic
    if (det(IB) != 1) {
      # damn, we have an cyclic model; use nlminb()
      PSI <- lav_mlist_target_psi(IB.inv = IB.inv, PSI = PSI,
                                      target.psi = target.psi, y.idx = y.idx)
    } else {
      # for an acyclic model, we should be able to find the
      # residual analytically; simply by computing the model-based
      # total variances of the RHS of each regression, and set the
      # residual of the y variable so that it is exactly equal to unity
      # (yes, this will result in negative resdidual variances if needed)

      # ideally, we first sort the variables 'in topological order'; then
      # we need only one run; but here we are somewhat lazy, and we
      # use a few runs, each time setting more variables right

      # get ancestors list for each node/variable
      ancestors <- lav_graph_get_ancestors(BETA)

      # for each y variable, compute IB.inv %*% psi %*% t(IB.inv), without y
      ny <- length(y.idx)
      max_rep <- ny * 4
      for(rep in seq_len(max_rep)) {
        if (debug) {
          cat("rep = ", rep, "\n")
        }
        # check current diagonal
        current.diag <- diag(IB.inv %*% PSI %*% t(IB.inv))
        if (debug) {
          cat("target.psi   = ", target.psi[y.idx], "\n")
          cat("current.diag = ", current.diag[y.idx], "\n")
        }
        if (all(abs(current.diag[y.idx] - target.psi[y.idx]) < tol)) {
          # we are done, bail out
          break
        }
        for (i in seq_len(ny)) {
          this.y.idx <- y.idx[i]
          this.x.idx <- ancestors[[this.y.idx]]
          IB.inv.y <- IB.inv[this.y.idx, this.x.idx, drop = FALSE]
          PSI.x <- PSI[this.x.idx, this.x.idx, drop = FALSE]
          var.y <- drop(IB.inv.y %*% PSI.x %*% t(IB.inv.y))
          PSI[this.y.idx, this.y.idx] <- target.psi[this.y.idx] - var.y
        }
      }

      # final check?
      current.diag <- diag(IB.inv %*% PSI %*% t(IB.inv))
      if (debug) {
        cat("final current.diag = ", current.diag[y.idx], "\n")
      }
      # don't be too strict here
      if (any(abs(current.diag[y.idx] - target.psi[y.idx]) > sqrt(tol))) {
        # as a last resort, use optimization
        PSI <- lav_mlist_target_psi(IB.inv = IB.inv, PSI = PSI,
                                        target.psi = target.psi, y.idx = y.idx)
      }

    } # acyclic
  } # phase 1

  # store PSI
  MLIST$psi <- PSI

  # phase 2: set residual variances in theta

  # force non-numeric theta elements to be zero
  if (length(num.idx) > 0L) {
    diag(MLIST$theta)[-num.idx] <- 0.0
  } else {
    diag(MLIST$theta) <- 0.0
  }

  Sigma.hat <- lav_lisrel_sigma(MLIST = MLIST, delta = FALSE)
  diag.Sigma <- diag(Sigma.hat)
  # theta = DELTA^(-2) - diag( LAMBDA (I-B)^-1 PSI (I-B)^-T t(LAMBDA) )
  theta.diag <- target.all - diag.Sigma
  not.idx <- unique(c(num.idx, ov.y.dummy.ov.idx))
  if (length(not.idx) > 0L) {
    diag(MLIST$theta)[-not.idx] <- theta.diag[-not.idx]
  } else {
    diag(MLIST$theta) <- theta.diag
  }

  MLIST
}

# if THETA parameterization, compute delta elements
# of observed categorical variables, as a function of other model parameters
lav_lisrel_delta <- function(MLIST = NULL, num.idx = NULL) {
  Sigma.hat <- lav_lisrel_sigma(MLIST = MLIST, delta = FALSE)
  diag.Sigma <- diag(Sigma.hat)

  # (1/delta^2) = diag( LAMBDA (I-B)^-1 PSI (I-B)^-T t(LAMBDA) ) + THETA
  # tmp <- diag.Sigma + THETA
  tmp <- diag.Sigma
  tmp[tmp < 0] <- as.numeric(NA)
  MLIST$delta[, 1L] <- sqrt(1 / tmp)

  # numeric delta's stay 1.0
  if (length(num.idx) > 0L) {
    MLIST$delta[num.idx] <- 1.0
  }

  MLIST
}

# compute Sigma/ETA: variances/covariances of BOTH observed and latent variables
lav_lisrel_cov_both <- function(MLIST = NULL, delta = TRUE) {
  LAMBDA <- MLIST$lambda
  nvar <- nrow(LAMBDA)
  PSI <- MLIST$psi
  nlat <- nrow(PSI)
  THETA <- MLIST$theta
  BETA <- MLIST$beta

  # 'extend' matrices
  LAMBDA2 <- rbind(LAMBDA, diag(nlat))
  THETA2 <- lav_matrix_bdiag(THETA, matrix(0, nlat, nlat))


  # beta?
  if (is.null(BETA)) {
    LAMBDA..IB.inv <- LAMBDA2
  } else {
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
    LAMBDA..IB.inv <- LAMBDA2 %*% IB.inv
  }

  # compute augment COV matrix
  COV <- tcrossprod(LAMBDA..IB.inv %*% PSI, LAMBDA..IB.inv) + THETA2

  # if delta, scale
  if (delta && !is.null(MLIST$delta)) {
    DELTA <- diag(MLIST$delta[, 1L], nrow = nvar, ncol = nvar)
    COV[seq_len(nvar), seq_len(nvar)] <-
      DELTA %*% COV[seq_len(nvar), seq_len(nvar)] %*% DELTA
  }


  # if GAMMA, also x part
  GAMMA <- MLIST$gamma
  if (!is.null(GAMMA)) {
    COV.X <- MLIST$cov.x
    if (is.null(BETA)) {
      SX <- tcrossprod(GAMMA %*% COV.X, GAMMA)
    } else {
      IB.inv..GAMMA <- IB.inv %*% GAMMA
      SX <- tcrossprod(IB.inv..GAMMA %*% COV.X, IB.inv..GAMMA)
    }
    COV[(nvar + 1):(nvar + nlat), (nvar + 1):(nvar + nlat)] <-
      COV[(nvar + 1):(nvar + nlat), (nvar + 1):(nvar + nlat)] + SX
  }

  COV
}


# derivative of the objective function
lav_lisrel_df_dmlist <- function(MLIST = NULL, Omega = NULL, Omega.mu = NULL) {
  LAMBDA <- MLIST$lambda
  PSI <- MLIST$psi
  BETA <- MLIST$beta
  ALPHA <- MLIST$alpha
  WMAT <- MLIST$wmat

  LAMBDA.deriv  <- NULL
  BETA.deriv    <- NULL
  THETA.deriv   <- NULL
  PSI.deriv     <- NULL
  NU.deriv      <- NULL
  ALPHA.deriv   <- NULL
  GROUP.W.deriv <- NULL
  WMAT.deriv    <- NULL

  # beta?
  if (is.null(BETA)) {
    LAMBDA..IB.inv <- LAMBDA
  } else {
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
    LAMBDA..IB.inv <- LAMBDA %*% IB.inv
  }

  # meanstructure?
  meanstructure <- FALSE
  if (!is.null(Omega.mu)) meanstructure <- TRUE

  # group weight?
  group.w.free <- FALSE
  if (!is.null(MLIST$gw)) group.w.free <- TRUE

  # pre-compute some values
  tLAMBDA..IB.inv <- t(LAMBDA..IB.inv)
  if (!is.null(BETA)) {
    Omega..LAMBDA..IB.inv..PSI..tIB.inv <-
      (Omega %*% LAMBDA..IB.inv %*% PSI %*% t(IB.inv))
  } else {
    Omega..LAMBDA <- Omega %*% LAMBDA
  }

  # 1. LAMBDA
  if (!is.null(BETA)) {
    if (meanstructure) {
    LAMBDA.deriv <- -1.0 * (Omega.mu %*% t(ALPHA) %*% t(IB.inv) +
        Omega..LAMBDA..IB.inv..PSI..tIB.inv)
    } else {
      LAMBDA.deriv <- -1.0 * Omega..LAMBDA..IB.inv..PSI..tIB.inv
    }
  } else {
    # no BETA
    if (meanstructure) {
      LAMBDA.deriv <- -1.0 * (Omega.mu %*% t(ALPHA) +
        Omega..LAMBDA %*% PSI)
    } else {
      LAMBDA.deriv <- -1.0 * (Omega..LAMBDA %*% PSI)
    }
  }

  # 2. BETA
  if (!is.null(BETA)) {
    if (meanstructure) {
      BETA.deriv <- -1.0 * ((t(IB.inv) %*%
        (t(LAMBDA) %*% Omega.mu %*% t(ALPHA)) %*%
        t(IB.inv)) +
        (tLAMBDA..IB.inv %*%
          Omega..LAMBDA..IB.inv..PSI..tIB.inv))
    } else {
      BETA.deriv <- -1.0 * (tLAMBDA..IB.inv %*%
        Omega..LAMBDA..IB.inv..PSI..tIB.inv)
    }
  }

  # 3. PSI
  PSI.deriv <- -1.0 * (tLAMBDA..IB.inv %*% Omega %*% LAMBDA..IB.inv)
  diag(PSI.deriv) <- 0.5 * diag(PSI.deriv)

  # 4. THETA
  THETA.deriv <- -1.0 * Omega
  diag(THETA.deriv) <- 0.5 * diag(THETA.deriv)

  if (meanstructure) {
    # 5. NU
    NU.deriv <- -1.0 * Omega.mu

    # 6. ALPHA
    ALPHA.deriv <- -1.0 * t(t(Omega.mu) %*% LAMBDA..IB.inv)
  }

  if (group.w.free) {
    GROUP.W.deriv <- 0.0
  }

  list(
    lambda = LAMBDA.deriv,
    wmat = WMAT.deriv,
    beta = BETA.deriv,
    theta = THETA.deriv,
    psi = PSI.deriv,
    nu = NU.deriv,
    alpha = ALPHA.deriv,
    gw = GROUP.W.deriv
  )
}

# dSigma/dx -- per model matrix
# note:
# we avoid using the duplication and elimination matrices
# for now (perhaps until we'll use the Matrix package)
lav_lisrel_dsigma_dx_old <- function(MLIST = NULL,
                                     m = "lambda",
                                     # all model matrix elements, or only a few?
                                     # NOTE: for symmetric matrices,
                                     # we assume that the have full size
                                     # (nvar*nvar) (but already correct for
                                     # symmetry)
                                     idx = seq_len(length(MLIST[[m]])),
                                     delta = TRUE) {
  LAMBDA <- MLIST$lambda
  nvar <- nrow(LAMBDA)
  nfac <- ncol(LAMBDA)
  PSI <- MLIST$psi

  # only lower.tri part of sigma (not same order as elimination matrix?)
  v.idx <- lav_matrix_vech_idx(nvar)
  pstar <- nvar * (nvar + 1) / 2

  # shortcut for gamma, nu, alpha and tau: empty matrix
  if (m == "nu" || m == "alpha" || m == "tau" || m == "gamma" || m == "gw" ||
    m == "cov.x" || m == "mean.x") {
    return(matrix(0.0, nrow = pstar, ncol = length(idx)))
  }

  # Delta?
  delta.flag <- FALSE
  if (delta && !is.null(MLIST$delta)) {
    DELTA <- MLIST$delta
    delta.flag <- TRUE
  } else if (m == "delta") { # modindices?
    return(matrix(0.0, nrow = pstar, ncol = length(idx)))
  }

  # beta?
  if (!is.null(MLIST$ibeta.inv)) {
    IB.inv <- MLIST$ibeta.inv
  } else {
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
  }

  # pre
  if (m == "lambda" || m == "beta") {
    IK <- diag(nvar * nvar) + lav_matrix_commutation(nvar, nvar)
  }
  if (m == "lambda" || m == "beta") {
    IB.inv..PSI..tIB.inv..tLAMBDA <-
      IB.inv %*% PSI %*% t(IB.inv) %*% t(LAMBDA)
  }
  if (m == "beta" || m == "psi") {
    LAMBDA..IB.inv <- LAMBDA %*% IB.inv
  }

  # here we go:
  if (m == "lambda") {
    DX <- IK %*% t(IB.inv..PSI..tIB.inv..tLAMBDA %x% diag(nvar))
    if (delta.flag) {
      DX <- DX * as.vector(DELTA %x% DELTA)
    }
  } else if (m == "beta") {
    DX <- IK %*% (t(IB.inv..PSI..tIB.inv..tLAMBDA) %x% LAMBDA..IB.inv)
    # this is not really needed (because we select idx=m.el.idx)
    # but just in case we need all elements of beta...
    DX[, lav_matrix_diag_idx(nfac)] <- 0.0
    if (delta.flag) {
      DX <- DX * as.vector(DELTA %x% DELTA)
    }
  } else if (m == "psi") {
    DX <- (LAMBDA..IB.inv %x% LAMBDA..IB.inv)
    # symmetry correction, but keeping all duplicated elements
    # since we depend on idx=m.el.idx
    # otherwise, we could simply postmultiply with the duplicationMatrix

    # we sum up lower.tri + upper.tri (but not the diagonal elements!)
    # imatrix <- matrix(1:nfac^2,nfac,nfac)
    # lower.idx <- imatrix[lower.tri(imatrix, diag=FALSE)]
    # upper.idx <- imatrix[upper.tri(imatrix, diag=FALSE)]
    lower.idx <- lav_matrix_vech_idx(nfac, diagonal = FALSE)
    upper.idx <- lav_matrix_vechru_idx(nfac, diagonal = FALSE)
    # NOTE YR: upper.idx (see 3 lines up) is wrong in MH patch!
    # fixed again 13/06/2012 after bug report of Mijke Rhemtulla.

    offdiagSum <- DX[, lower.idx] + DX[, upper.idx]
    DX[, c(lower.idx, upper.idx)] <- cbind(offdiagSum, offdiagSum)
    if (delta.flag) {
      DX <- DX * as.vector(DELTA %x% DELTA)
    }
  } else if (m == "theta") {
    DX <- diag(nvar * nvar) # very sparse...
    # symmetry correction not needed, since all off-diagonal elements
    # are zero?
    if (delta.flag) {
      DX <- DX * as.vector(DELTA %x% DELTA)
    }
  } else if (m == "delta") {
    Omega <- lav_lisrel_sigma(MLIST, delta = FALSE)
    DD <- diag(DELTA[, 1], nvar, nvar)
    DD.Omega <- (DD %*% Omega)
    A <- DD.Omega %x% diag(nvar)
    B <- diag(nvar) %x% DD.Omega
    DX <- A[, lav_matrix_diag_idx(nvar), drop = FALSE] +
      B[, lav_matrix_diag_idx(nvar), drop = FALSE]
  } else {
    lav_msg_stop(gettext("wrong model matrix names:"), m)
  }

  DX <- DX[v.idx, idx, drop = FALSE]
  DX
}

# dSigma/dx -- per model matrix
lav_lisrel_dsigma_dx <- function(MLIST = NULL,
                                 m = "lambda",
                                 # all model matrix elements, or only a few?
                                 # NOTE: for symmetric matrices,
                                 # we assume that the have full size
                                 # (nvar*nvar) (but already correct for
                                 # symmetry)
                                 idx = seq_len(length(MLIST[[m]])),
                                 vech = TRUE,
                                 delta = TRUE) {
  LAMBDA <- MLIST$lambda
  nvar <- nrow(LAMBDA)
  nfac <- ncol(LAMBDA)
  PSI <- MLIST$psi
  WMAT <- MLIST$wmat

  # for composites (vec version)
  compute.sigma <- function(x, mm = "wmat", MLIST = NULL) {
    mlist <- MLIST
    if (mm %in% c("psi", "theta")) {
      mlist[[mm]] <- lav_matrix_vech_reverse(x)
    } else {
      mlist[[mm]][, ] <- x
    }
    lav_matrix_vec(lav_lisrel_sigma(mlist))
  }

  composites <- FALSE
  if (!is.null(WMAT)) {
    composites <- TRUE
  }

  # only lower.tri part of sigma (not same order as elimination matrix?)
  v.idx <- lav_matrix_vech_idx(nvar)
  pstar <- nvar * (nvar + 1) / 2

  # shortcut for gamma, nu, alpha, tau,.... : empty matrix
  if (m == "nu" || m == "alpha" || m == "tau" || m == "gamma" ||
    m == "gw" || m == "cov.x" || m == "mean.x") {
    return(matrix(0.0, nrow = pstar, ncol = length(idx)))
  }

  # Delta?
  delta.flag <- FALSE
  if (delta && !is.null(MLIST$delta)) {
    DELTA <- MLIST$delta
    delta.flag <- TRUE
  } else if (m == "delta") { # modindices?
    return(matrix(0.0, nrow = pstar, ncol = length(idx)))
  }

  # beta?
  if (!is.null(MLIST$ibeta.inv)) {
    IB.inv <- MLIST$ibeta.inv
  } else {
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
  }

  # pre
  # if(m == "lambda" || m == "beta")
  #    IK <- diag(nvar*nvar) + lav_matrix_commutation(nvar, nvar)
  if (m == "lambda" || m == "beta") {
    L1 <- LAMBDA %*% IB.inv %*% PSI %*% t(IB.inv)
  }
  if (m == "beta" || m == "psi") {
    LAMBDA..IB.inv <- LAMBDA %*% IB.inv
  }

  # here we go:
  if (m == "lambda") {
    KOL.idx <- matrix(1:(nvar * nfac), nvar, nfac, byrow = TRUE)[idx]
    DX <- (L1 %x% diag(nvar))[, idx, drop = FALSE] +
      (diag(nvar) %x% L1)[, KOL.idx, drop = FALSE]
  } else if (m == "beta") {
    if (composites) {
      DX <- lav_func_jacobian_complex(func = compute.sigma,
            x = lav_matrix_vec(MLIST$beta),
            mm = "beta", MLIST = MLIST)
      DX <- DX[, idx, drop = FALSE]
    } else {
      KOL.idx <- matrix(1:(nfac * nfac), nfac, nfac, byrow = TRUE)[idx]
      DX <- (L1 %x% LAMBDA..IB.inv)[, idx, drop = FALSE] +
        (LAMBDA..IB.inv %x% L1)[, KOL.idx, drop = FALSE]
      # this is not really needed (because we select idx=m.el.idx)
      # but just in case we need all elements of beta...
      DX[, which(idx %in% lav_matrix_diag_idx(nfac))] <- 0.0
    }
  } else if (m == "psi") {
    if (composites) {
      tmp <- lav_func_jacobian_complex(func = compute.sigma,
            x = lav_matrix_vech(MLIST$psi),
            mm = "psi", MLIST = MLIST)
      DX <- matrix(0, nrow = nrow(tmp), ncol = length(PSI))
      DX[, lav_matrix_vech_idx(nrow(PSI))] <- tmp
      DX[, lav_matrix_vechu_idx(nrow(PSI), diagonal = FALSE)] <-
        DX[, lav_matrix_vech_idx(nrow(PSI), diagonal = FALSE), drop = FALSE]
      DX <- DX[, idx, drop = FALSE]
    } else {
      DX <- (LAMBDA..IB.inv %x% LAMBDA..IB.inv)
      # symmetry correction, but keeping all duplicated elements
      # since we depend on idx=m.el.idx
      lower.idx <- lav_matrix_vech_idx(nfac, diagonal = FALSE)
      upper.idx <- lav_matrix_vechru_idx(nfac, diagonal = FALSE)
      offdiagSum <- DX[, lower.idx] + DX[, upper.idx]
      DX[, c(lower.idx, upper.idx)] <- cbind(offdiagSum, offdiagSum)
      DX <- DX[, idx, drop = FALSE]
    }
  } else if (m == "theta") {
    # DX <- diag(nvar*nvar) # very sparse...
    DX <- matrix(0, nvar * nvar, length(idx))
    DX[cbind(idx, seq_along(idx))] <- 1
    # symmetry correction not needed, since all off-diagonal elements
    # are zero?
  } else if (m == "delta") {
    Omega <- lav_lisrel_sigma(MLIST, delta = FALSE)
    DD <- diag(DELTA[, 1], nvar, nvar)
    DD.Omega <- (DD %*% Omega)
    A <- DD.Omega %x% diag(nvar)
    B <- diag(nvar) %x% DD.Omega
    DX <- A[, lav_matrix_diag_idx(nvar), drop = FALSE] +
      B[, lav_matrix_diag_idx(nvar), drop = FALSE]
    DX <- DX[, idx, drop = FALSE]
  } else if (m == "wmat") {
    # just a dummy to get us going
    DX <- lav_func_jacobian_complex(func = compute.sigma,
            x = lav_matrix_vec(WMAT),
            mm = "wmat", MLIST = MLIST)
    DX <- DX[, idx, drop = FALSE]

    # KOL.idx <- matrix(1:(nvar * nfac), nvar, nfac, byrow = TRUE)[idx]
    # VETA <- IB.inv %*% PSI %*% t(IB.inv)
    # C0 <- VETA; diag(C0) <- 0
    # cov.idx <- which(apply(LAMBDA, 1L,
    #                        function(x) sum(x == 0) == ncol(LAMBDA)))
    # clv.idx <- which(apply(LAMBDA, 2L,
    #                        function(x) sum(x == 0) == nrow(LAMBDA)))
    # Tmat <- diag(nrow(LAMBDA))
    # Tmat[cov.idx, cov.idx] <- MLIST$theta[cov.idx, cov.idx]
    # L1 <- Tmat %*% WMAT %*% C0
    # DX <- (L1 %x% diag(nvar))[, idx, drop = FALSE] +
    #   (diag(nvar) %x% L1)[, KOL.idx, drop = FALSE]
    # DX <- DX * nfac
  } else {
    lav_msg_stop(gettext("wrong model matrix name:"), m)
  }

  if (delta.flag && !m == "delta") {
    DX <- DX * as.vector(DELTA %x% DELTA)
  }

  # vech?
  if (vech) {
    DX <- DX[v.idx, , drop = FALSE]
  }

  DX
}

# dMu/dx -- per model matrix
lav_lisrel_dmu_dx <- function(MLIST = NULL,
                              m = "alpha",
                              # all model matrix elements, or only a few?
                              idx = seq_len(length(MLIST[[m]]))) {
  LAMBDA <- MLIST$lambda
  nvar <- nrow(LAMBDA)
  nfac <- ncol(LAMBDA)
  WMAT <- MLIST$wmat

  # shortcut for empty matrices
  if (m == "gamma" || m == "psi" || m == "theta" || m == "tau" ||
    m == "delta" || m == "gw" || m == "cov.x" || m == "mean.x") {
    return(matrix(0.0, nrow = nvar, ncol = length(idx)))
  }

  # missing alpha
  if (is.null(MLIST$alpha)) {
    ALPHA <- matrix(0, nfac, 1L)
  } else {
    ALPHA <- MLIST$alpha
  }


  # beta?
  if (!is.null(MLIST$ibeta.inv)) {
    IB.inv <- MLIST$ibeta.inv
  } else {
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
  }

  if (m == "nu") {
    DX <- diag(nvar)
  } else if (m == "lambda") {
    DX <- t(IB.inv %*% ALPHA) %x% diag(nvar)
  } else if (m == "wmat") {
    # dummy, just to get us going
    DX <- t(IB.inv %*% ALPHA) %x% diag(nvar)
  } else if (m == "beta") {
    DX <- t(IB.inv %*% ALPHA) %x% (LAMBDA %*% IB.inv)
    # this is not really needed (because we select idx=m.el.idx)
    DX[, lav_matrix_diag_idx(nfac)] <- 0.0
  } else if (m == "alpha") {
    DX <- LAMBDA %*% IB.inv
  } else {
    lav_msg_stop(gettext("wrong model matrix names:"), m)
  }

  DX <- DX[, idx, drop = FALSE]
  DX
}

# dTh/dx -- per model matrix
lav_lisrel_dth_dx <- function(MLIST = NULL,
                              m = "tau",
                              # all model matrix elements, or only a few?
                              idx = seq_len(length(MLIST[[m]])),
                              th.idx = NULL,
                              delta = TRUE) {
  LAMBDA <- MLIST$lambda
  nvar <- nrow(LAMBDA)
  nfac <- ncol(LAMBDA)
  TAU <- MLIST$tau
  nth <- nrow(TAU)

  # missing alpha
  if (is.null(MLIST$alpha)) {
    ALPHA <- matrix(0, nfac, 1L)
  } else {
    ALPHA <- MLIST$alpha
  }

  # missing nu
  if (is.null(MLIST$nu)) {
    NU <- matrix(0, nvar, 1L)
  } else {
    NU <- MLIST$nu
  }

  # Delta?
  delta.flag <- FALSE
  if (delta && !is.null(MLIST$delta)) {
    DELTA <- MLIST$delta
    delta.flag <- TRUE
  }

  if (is.null(th.idx)) {
    th.idx <- seq_len(nth)
    nlev <- rep(1L, nvar)
    K_nu <- diag(nvar)
  } else {
    nlev <- tabulate(th.idx, nbins = nvar)
    nlev[nlev == 0L] <- 1L
    K_nu <- matrix(0, sum(nlev), nvar)
    K_nu[cbind(seq_len(sum(nlev)), rep(seq_len(nvar), times = nlev))] <- 1.0
  }

  # shortcut for empty matrices
  if (m == "gamma" || m == "psi" || m == "theta" || m == "gw" ||
    m == "cov.x" || m == "mean.x") {
    return(matrix(0.0, nrow = length(th.idx), ncol = length(idx)))
  }

  # beta?
  if (!is.null(MLIST$ibeta.inv)) {
    IB.inv <- MLIST$ibeta.inv
  } else {
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
  }

  if (m == "tau") {
    DX <- matrix(0, nrow = length(th.idx), ncol = nth)
    DX[th.idx > 0L, ] <- diag(nth)
    if (delta.flag) {
      DX <- DX * as.vector(K_nu %*% DELTA)
    }
  } else if (m == "nu") {
    DX <- (-1) * K_nu
    if (delta.flag) {
      DX <- DX * as.vector(K_nu %*% DELTA)
    }
  } else if (m == "lambda") {
    DX <- (-1) * t(IB.inv %*% ALPHA) %x% diag(nvar)
    DX <- K_nu %*% DX
    if (delta.flag) {
      DX <- DX * as.vector(K_nu %*% DELTA)
    }
  } else if (m == "beta") {
    DX <- (-1) * t(IB.inv %*% ALPHA) %x% (LAMBDA %*% IB.inv)
    # this is not really needed (because we select idx=m.el.idx)
    DX[, lav_matrix_diag_idx(nfac)] <- 0.0
    DX <- K_nu %*% DX
    if (delta.flag) {
      DX <- DX * as.vector(K_nu %*% DELTA)
    }
  } else if (m == "alpha") {
    DX <- (-1) * LAMBDA %*% IB.inv
    DX <- K_nu %*% DX
    if (delta.flag) {
      DX <- DX * as.vector(K_nu %*% DELTA)
    }
  } else if (m == "delta") {
    DX1 <- matrix(0, nrow = length(th.idx), ncol = 1)
    DX1[th.idx > 0L, ] <- TAU
    DX2 <- NU + LAMBDA %*% IB.inv %*% ALPHA
    DX2 <- K_nu %*% DX2
    DX <- K_nu * as.vector(DX1 - DX2)
  } else {
    lav_msg_stop(gettext("wrong model matrix names:"), m)
  }

  DX <- DX[, idx, drop = FALSE]
  DX
}

# dPi/dx -- per model matrix
lav_lisrel_dpi_dx <- function(MLIST = NULL,
                              m = "lambda",
                              # all model matrix elements, or only a few?
                              idx = seq_len(length(MLIST[[m]]))) {
  LAMBDA <- MLIST$lambda
  nvar <- nrow(LAMBDA)
  nfac <- ncol(LAMBDA)
  GAMMA <- MLIST$gamma
  nexo <- ncol(GAMMA)

  # Delta?
  delta.flag <- FALSE
  if (!is.null(MLIST$delta)) {
    DELTA.diag <- MLIST$delta[, 1L]
    delta.flag <- TRUE
  }

  # shortcut for empty matrices
  if (m == "tau" || m == "nu" || m == "alpha" || m == "psi" ||
    m == "theta" || m == "gw" || m == "cov.x" || m == "mean.x") {
    return(matrix(0.0, nrow = nvar * nexo, ncol = length(idx)))
  }

  # beta?
  if (!is.null(MLIST$ibeta.inv)) {
    IB.inv <- MLIST$ibeta.inv
  } else {
    IB.inv <- lav_lisrel_ibinv(MLIST = MLIST)
  }

  if (m == "lambda") {
    DX <- t(IB.inv %*% GAMMA) %x% diag(nvar)
    if (delta.flag) {
      DX <- DX * DELTA.diag
    }
  } else if (m == "beta") {
    DX <- t(IB.inv %*% GAMMA) %x% (LAMBDA %*% IB.inv)
    # this is not really needed (because we select idx=m.el.idx)
    DX[, lav_matrix_diag_idx(nfac)] <- 0.0
    if (delta.flag) {
      DX <- DX * DELTA.diag
    }
  } else if (m == "gamma") {
    DX <- diag(nexo) %x% (LAMBDA %*% IB.inv)
    if (delta.flag) {
      DX <- DX * DELTA.diag
    }
  } else if (m == "delta") {
    PRE <- rep(1, nexo) %x% diag(nvar)
    DX <- PRE * as.vector(LAMBDA %*% IB.inv %*% GAMMA)
  } else {
    lav_msg_stop(gettext("wrong model matrix names:"), m)
  }

  DX <- DX[, idx, drop = FALSE]
  DX
}

# dGW/dx -- per model matrix
lav_lisrel_dgw_dx <- function(MLIST = NULL,
                              m = "gw",
                              # all model matrix elements, or only a few?
                              idx = seq_len(length(MLIST[[m]]))) {
  # shortcut for empty matrices
  if (m != "gw") {
    return(matrix(0.0, nrow = 1L, ncol = length(idx)))
  } else {
    # m == "gw"
    DX <- matrix(1.0, 1, 1)
  }

  DX <- DX[, idx, drop = FALSE]
  DX
}

# dlambda/dx -- per model matrix
lav_lisrel_dlambda_dx <- function(MLIST = NULL,
                                  m = "lambda",
                                  # all model matrix elements, or only a few?
                                  idx = seq_len(length(MLIST[[m]]))) {
  LAMBDA <- MLIST$lambda

  # shortcut for empty matrices
  if (m != "lambda") {
    return(matrix(0.0, nrow = length(LAMBDA), ncol = length(idx)))
  } else {
    # m == "lambda"
    DX <- diag(1, nrow = length(LAMBDA), ncol = length(LAMBDA))
  }

  DX <- DX[, idx, drop = FALSE]
  DX
}

# dpsi/dx -- per model matrix - FIXME!!!!!
lav_lisrel_dpsi_dx <- function(MLIST = NULL,
                               m = "psi",
                               # all model matrix elements, or only a few?
                               idx = seq_len(length(MLIST[[m]]))) {
  PSI <- MLIST$psi
  nfac <- nrow(PSI)
  v.idx <- lav_matrix_vech_idx(nfac)

  # shortcut for empty matrices
  if (m != "psi") {
    DX <- matrix(0.0, nrow = length(PSI), ncol = length(idx))
    return(DX[v.idx, , drop = FALSE])
  } else {
    # m == "psi"
    DX <- diag(1, nrow = length(PSI), ncol = length(PSI))
  }

  DX <- DX[v.idx, idx, drop = FALSE]
  DX
}

# dtheta/dx -- per model matrix
lav_lisrel_dtheta_dx <- function(MLIST = NULL,
                                 m = "theta",
                                 # all model matrix elements, or only a few?
                                 idx = seq_len(length(MLIST[[m]]))) {
  THETA <- MLIST$theta
  nvar <- nrow(THETA)
  v.idx <- lav_matrix_vech_idx(nvar)

  # shortcut for empty matrices
  if (m != "theta") {
    DX <- matrix(0.0, nrow = length(THETA), ncol = length(idx))
    return(DX[v.idx, , drop = FALSE])
  } else {
    # m == "theta"
    DX <- diag(1, nrow = length(THETA), ncol = length(THETA))
  }

  DX <- DX[v.idx, idx, drop = FALSE]
  DX
}


# dbeta/dx -- per model matrix
lav_lisrel_dbeta_dx <- function(MLIST = NULL,
                                m = "beta",
                                # all model matrix elements, or only a few?
                                idx = seq_len(length(MLIST[[m]]))) {
  BETA <- MLIST$beta

  # shortcut for empty matrices
  if (m != "beta") {
    return(matrix(0.0, nrow = length(BETA), ncol = length(idx)))
  } else {
    # m == "beta"
    DX <- diag(1, nrow = length(BETA), ncol = length(BETA))
  }

  DX <- DX[, idx, drop = FALSE]
  DX
}

# dgamma/dx -- per model matrix
lav_lisrel_dgamma_dx <- function(MLIST = NULL,
                                 m = "gamma",
                                 # all model matrix elements, or only a few?
                                 idx = seq_len(length(MLIST[[m]]))) {
  GAMMA <- MLIST$gamma

  # shortcut for empty matrices
  if (m != "gamma") {
    return(matrix(0.0, nrow = length(GAMMA), ncol = length(idx)))
  } else {
    # m == "gamma"
    DX <- diag(1, nrow = length(GAMMA), ncol = length(GAMMA))
  }

  DX <- DX[, idx, drop = FALSE]
  DX
}

# dnu/dx -- per model matrix
lav_lisrel_dnu_dx <- function(MLIST = NULL,
                              m = "nu",
                              # all model matrix elements, or only a few?
                              idx = seq_len(length(MLIST[[m]]))) {
  NU <- MLIST$nu

  # shortcut for empty matrices
  if (m != "nu") {
    return(matrix(0.0, nrow = length(NU), ncol = length(idx)))
  } else {
    # m == "nu"
    DX <- diag(1, nrow = length(NU), ncol = length(NU))
  }

  DX <- DX[, idx, drop = FALSE]
  DX
}

# dtau/dx -- per model matrix
lav_lisrel_dtau_dx <- function(MLIST = NULL,
                               m = "tau",
                               # all model matrix elements, or only a few?
                               idx = seq_len(length(MLIST[[m]]))) {
  TAU <- MLIST$tau

  # shortcut for empty matrices
  if (m != "tau") {
    return(matrix(0.0, nrow = length(TAU), ncol = length(idx)))
  } else {
    # m == "tau"
    DX <- diag(1, nrow = length(TAU), ncol = length(TAU))
  }

  DX <- DX[, idx, drop = FALSE]
  DX
}



# dalpha/dx -- per model matrix
lav_lisrel_dalpha_dx <- function(MLIST = NULL,
                                 m = "alpha",
                                 # all model matrix elements, or only a few?
                                 idx = seq_len(length(MLIST[[m]]))) {
  ALPHA <- MLIST$alpha

  # shortcut for empty matrices
  if (m != "alpha") {
    return(matrix(0.0, nrow = length(ALPHA), ncol = length(idx)))
  } else {
    # m == "alpha"
    DX <- diag(1, nrow = length(ALPHA), ncol = length(ALPHA))
  }

  DX <- DX[, idx, drop = FALSE]
  DX
}

# MLIST = NULL; meanstructure=TRUE; th=TRUE; delta=TRUE; pi=TRUE; gw=FALSE
# lav_matrix_vech_idx <- lavaan:::lav_matrix_vech_idx; lav_matrix_vechru_idx <- lavaan:::lav_matrix_vechru_idx
# vec <- lavaan:::vec; lav_func_jacobian_complex <- lavaan:::lav_func_jacobian_complex
# lav_lisrel_sigma <- lavaan:::lav_lisrel_sigma
# lav_lisrel_delta <- lavaan:::lav_lisrel_delta
lav_lisrel_test_derivatives  <- function(MLIST = NULL,
                                         nvar = NULL, nfac = NULL, nexo = NULL,
                                         th.idx = NULL, num.idx = NULL,
                                         meanstructure = TRUE,
                                         th = TRUE, delta = TRUE, pi = TRUE,
                                         gw = FALSE, theta = FALSE) {
  if (is.null(MLIST)) {
    # create artificial matrices, compare 'numerical' vs 'analytical'
    # derivatives
    # nvar <- 12; nfac <- 3; nexo <- 4 # this combination is special?
    if (is.null(nvar)) {
      nvar <- 20
    }
    if (is.null(nfac)) {
      nfac <- 6
    }
    if (is.null(nexo)) {
      nexo <- 5
    }
    if (is.null(num.idx)) {
      num.idx <- sort(sample(seq_len(nvar), ceiling(nvar / 2)))
    }
    if (is.null(th.idx)) {
      th.idx <- integer(0L)
      for (i in seq_len(nvar)) {
        if (i %in% num.idx) {
          th.idx <- c(th.idx, 0)
        } else {
          th.idx <- c(th.idx, rep(i, sample(c(1, 1, 2, 6), 1L)))
        }
      }
    }
    nth <- sum(th.idx > 0L)

    MLIST <- list()
    MLIST$lambda <- matrix(0, nvar, nfac)
    MLIST$beta <- matrix(0, nfac, nfac)
    MLIST$theta <- matrix(0, nvar, nvar)
    MLIST$psi <- matrix(0, nfac, nfac)
    if (meanstructure) {
      MLIST$alpha <- matrix(0, nfac, 1L)
      MLIST$nu <- matrix(0, nvar, 1L)
    }
    if (th) MLIST$tau <- matrix(0, nth, 1L)
    if (delta) MLIST$delta <- matrix(0, nvar, 1L)
    MLIST$gamma <- matrix(0, nfac, nexo)
    if (gw) MLIST$gw <- matrix(0, 1L, 1L)

    # feed random numbers
    MLIST <- lapply(MLIST, function(x) {
      x[, ] <- rnorm(length(x))
      x
    })
    # fix
    diag(MLIST$beta) <- 0.0
    diag(MLIST$theta) <- diag(MLIST$theta) * diag(MLIST$theta) * 10
    diag(MLIST$psi) <- diag(MLIST$psi) * diag(MLIST$psi) * 10
    MLIST$psi[lav_matrix_vechru_idx(nfac)] <-
      MLIST$psi[lav_matrix_vech_idx(nfac)]
    MLIST$theta[lav_matrix_vechru_idx(nvar)] <-
      MLIST$theta[lav_matrix_vech_idx(nvar)]
    if (delta) MLIST$delta[, ] <- abs(MLIST$delta) * 10
  } else {
    nvar <- nrow(MLIST$lambda)
  }

  compute.sigma <- function(x, mm = "lambda", MLIST = NULL) {
    mlist <- MLIST
    if (mm %in% c("psi", "theta")) {
      mlist[[mm]] <- lav_matrix_vech_reverse(x)
    } else {
      mlist[[mm]][, ] <- x
    }
    if (theta) {
      mlist <- lav_lisrel_delta(MLIST = mlist, num.idx = num.idx)
    }
    lav_matrix_vech(lav_lisrel_sigma(mlist))
  }

  compute.mu <- function(x, mm = "lambda", MLIST = NULL) {
    mlist <- MLIST
    if (mm %in% c("psi", "theta")) {
      mlist[[mm]] <- lav_matrix_vech_reverse(x)
    } else {
      mlist[[mm]][, ] <- x
    }
    if (theta) {
      mlist <- lav_lisrel_delta(MLIST = mlist, num.idx = num.idx)
    }
    lav_lisrel_mu(mlist)
  }

  compute.th2 <- function(x, mm = "tau", MLIST = NULL, th.idx) {
    mlist <- MLIST
    if (mm %in% c("psi", "theta")) {
      mlist[[mm]] <- lav_matrix_vech_reverse(x)
    } else {
      mlist[[mm]][, ] <- x
    }
    if (theta) {
      mlist <- lav_lisrel_delta(MLIST = mlist, num.idx = num.idx)
    }
    lav_lisrel_th(mlist, th.idx = th.idx)
  }

  compute.pi <- function(x, mm = "lambda", MLIST = NULL) {
    mlist <- MLIST
    if (mm %in% c("psi", "theta")) {
      mlist[[mm]] <- lav_matrix_vech_reverse(x)
    } else {
      mlist[[mm]][, ] <- x
    }
    if (theta) {
      mlist <- lav_lisrel_delta(MLIST = mlist, num.idx = num.idx)
    }
    lav_lisrel_pi(mlist)
  }

  compute.gw <- function(x, mm = "gw", MLIST = NULL) {
    mlist <- MLIST
    if (mm %in% c("psi", "theta")) {
      mlist[[mm]] <- lav_matrix_vech_reverse(x)
    } else {
      mlist[[mm]][, ] <- x
    }
    if (theta) {
      mlist <- lav_lisrel_delta(MLIST = mlist, num.idx = num.idx)
    }
    mlist$gw[1, 1]
  }

  # if theta, set MLIST$delta
  if (theta) {
    MLIST <- lav_lisrel_delta(MLIST = MLIST, num.idx = num.idx)
  }

  for (mm in names(MLIST)) {
    if (mm %in% c("psi", "theta")) {
      x <- lav_matrix_vech(MLIST[[mm]])
    } else {
      x <- lav_matrix_vec(MLIST[[mm]])
    }
    if (mm == "delta" && theta) next
    if (lav_debug()) {
      cat("### mm = ", mm, "\n")
    }

    # 1. sigma
    DX1 <- lav_func_jacobian_complex(func = compute.sigma, x = x, mm = mm, MLIST = MLIST)
    DX2 <- lav_lisrel_dsigma_dx(
      MLIST = MLIST, m = mm, idx = seq_len(length(MLIST[[mm]])),
      delta = !theta
    )
    if (mm %in% c("psi", "theta")) {
      # remove duplicated columns of symmetric matrices
      idx <- lav_matrix_vechru_idx(sqrt(ncol(DX2)), diagonal = FALSE)
      if (length(idx) > 0L) DX2 <- DX2[, -idx]
    }
    if (theta) {
      sigma.hat <- lav_lisrel_sigma(MLIST = MLIST, delta = FALSE)
      R <- lav_deriv_cov2cor(sigma.hat, num.idx = num.idx)

      DX3 <- DX2
      DX2 <- R %*% DX2
    }
    if (lav_debug()) {
      cat("[SIGMA] mm = ", sprintf("%-8s:", mm), "DX1 (numerical):\n")
      print(zapsmall(DX1))
      cat("\n")
      cat("[SIGMA] mm = ", sprintf("%-8s:", mm), "DX2 (analytical):\n")
      print(DX2)
      cat("\n")
      if (theta) {
        cat("[SIGMA] mm = ", sprintf("%-8s:", mm), "DX3 (analytical):\n")
        print(DX3)
        cat("\n")
      }
    }
    cat(
      "[SIGMA] mm = ", sprintf("%-8s:", mm), "sum delta = ",
      sprintf("%12.9f", sum(DX1 - DX2)), "  max delta = ",
      sprintf("%12.9f", max(DX1 - DX2)), "\n"
    )

    # 2. mu
    DX1 <- lav_func_jacobian_complex(func = compute.mu, x = x, mm = mm, MLIST = MLIST)
    DX2 <- lav_lisrel_dmu_dx(
      MLIST = MLIST,
      m = mm, idx = seq_len(length(MLIST[[mm]]))
    )
    if (mm %in% c("psi", "theta")) {
      # remove duplicated columns of symmetric matrices
      idx <- lav_matrix_vechru_idx(sqrt(ncol(DX2)), diagonal = FALSE)
      if (length(idx) > 0L) DX2 <- DX2[, -idx]
    }
    cat(
      "[MU   ] mm = ", sprintf("%-8s:", mm), "sum delta = ",
      sprintf("%12.9f", sum(DX1 - DX2)), "  max delta = ",
      sprintf("%12.9f", max(DX1 - DX2)), "\n"
    )
    if (lav_debug()) {
      cat("[MU   ] mm = ", sprintf("%-8s:", mm), "DX1 (numerical):\n")
      print(zapsmall(DX1))
      cat("\n")
      cat("[MU   ] mm = ", sprintf("%-8s:", mm), "DX2 (analytical):\n")
      print(DX2)
      cat("\n")
    }

    # 3. th
    if (th) {
      DX1 <- lav_func_jacobian_complex(
        func = compute.th2, x = x, mm = mm, MLIST = MLIST,
        th.idx = th.idx
      )
      DX2 <- lav_lisrel_dth_dx(
         MLIST = MLIST, m = mm, idx = seq_len(length(MLIST[[mm]])),
        th.idx = th.idx,
        delta = TRUE
      )
      if (theta) {
        # 1. compute dDelta.dx
        dxSigma <-
          lav_lisrel_dsigma_dx(
            m = mm, idx = seq_len(length(MLIST[[mm]])),
            MLIST = MLIST, delta = !theta
          )
        var.idx <- which(!lav_matrix_vech_idx(nvar) %in%
          lav_matrix_vech_idx(nvar, diagonal = FALSE))
        sigma.hat <- lav_lisrel_sigma(MLIST = MLIST, delta = FALSE)
        dsigma <- diag(sigma.hat)
        # dy/ddsigma = -0.5/(ddsigma*sqrt(ddsigma))
        dDelta.dx <- dxSigma[var.idx, ] * -0.5 / (dsigma * sqrt(dsigma))

        # 2. compute dth.dDelta
        dth.dDelta <-
          lav_lisrel_dth_dx(
            MLIST = MLIST,
            m = "delta",
            idx = seq_len(length(MLIST[["delta"]])),
            th.idx = th.idx
          )

        # 3. add dth.dDelta %*% dDelta.dx
        no.num.idx <- which(th.idx > 0)
        DX2[no.num.idx, ] <- DX2[no.num.idx, , drop = FALSE] +
          (dth.dDelta %*% dDelta.dx)[no.num.idx, , drop = FALSE]
        # DX2 <- DX2 + dth.dDelta %*% dDelta.dx
      }
      if (mm %in% c("psi", "theta")) {
        # remove duplicated columns of symmetric matrices
        idx <- lav_matrix_vechru_idx(sqrt(ncol(DX2)), diagonal = FALSE)
        if (length(idx) > 0L) DX2 <- DX2[, -idx]
      }
      cat(
        "[TH   ] mm = ", sprintf("%-8s:", mm), "sum delta = ",
        sprintf("%12.9f", sum(DX1 - DX2)), "  max delta = ",
        sprintf("%12.9f", max(DX1 - DX2)), "\n"
      )
      if (lav_debug()) {
        cat("[TH   ] mm = ", sprintf("%-8s:", mm), "DX1 (numerical):\n")
        print(zapsmall(DX1))
        cat("\n")
        cat("[TH   ] mm = ", sprintf("%-8s:", mm), "DX2 (analytical):\n")
        print(DX2)
        cat("\n")
      }
    }

    # 4. pi
    if (pi) {
      DX1 <- lav_func_jacobian_complex(func = compute.pi, x = x, mm = mm, MLIST = MLIST)
      DX2 <- lav_lisrel_dpi_dx(
        MLIST = MLIST,
        m = mm, idx = seq_len(length(MLIST[[mm]]))
      )
      if (mm %in% c("psi", "theta")) {
        # remove duplicated columns of symmetric matrices
        idx <- lav_matrix_vechru_idx(sqrt(ncol(DX2)), diagonal = FALSE)
        if (length(idx) > 0L) DX2 <- DX2[, -idx]
      }
      if (theta) {
        # 1. compute dDelta.dx
        dxSigma <-
          lav_lisrel_dsigma_dx(
            MLIST = MLIST, m = mm, idx = seq_len(length(MLIST[[mm]])),
            delta = !theta
          )
        if (mm %in% c("psi", "theta")) {
          # remove duplicated columns of symmetric matrices
          idx <- lav_matrix_vechru_idx(sqrt(ncol(dxSigma)), diagonal = FALSE)
          if (length(idx) > 0L) dxSigma <- dxSigma[, -idx]
        }
        var.idx <- which(!lav_matrix_vech_idx(nvar) %in%
          lav_matrix_vech_idx(nvar, diagonal = FALSE))
        sigma.hat <- lav_lisrel_sigma(MLIST = MLIST, delta = FALSE)
        dsigma <- diag(sigma.hat)
        # dy/ddsigma = -0.5/(ddsigma*sqrt(ddsigma))
        dDelta.dx <- dxSigma[var.idx, ] * -0.5 / (dsigma * sqrt(dsigma))

        # 2. compute dpi.dDelta
        dpi.dDelta <-
          lav_lisrel_dpi_dx(
            MLIST = MLIST,
            m = "delta",
            idx = seq_len(length(MLIST[["delta"]]))
          )

        # 3. add dpi.dDelta %*% dDelta.dx
        no.num.idx <- which(!seq.int(1L, nvar) %in% num.idx)
        no.num.idx <- rep(seq.int(0, nexo - 1) * nvar,
          each = length(no.num.idx)
        ) + no.num.idx
        DX2[no.num.idx, ] <- DX2[no.num.idx, , drop = FALSE] +
          (dpi.dDelta %*% dDelta.dx)[no.num.idx, , drop = FALSE]
      }
      cat(
        "[PI   ] mm = ", sprintf("%-8s:", mm), "sum delta = ",
        sprintf("%12.9f", sum(DX1 - DX2)), "  max delta = ",
        sprintf("%12.9f", max(DX1 - DX2)), "\n"
      )
      if (lav_debug()) {
        cat("[PI   ] mm = ", sprintf("%-8s:", mm), "DX1 (numerical):\n")
        print(zapsmall(DX1))
        cat("\n")
        cat("[PI   ] mm = ", sprintf("%-8s:", mm), "DX2 (analytical):\n")
        print(DX2)
        cat("\n")
      }
    }

    # 5. gw
    if (gw) {
      DX1 <- lav_func_jacobian_complex(func = compute.gw, x = x, mm = mm, MLIST = MLIST)
      DX2 <- lav_lisrel_dgw_dx(
        MLIST = MLIST,
        m = mm, idx = seq_len(length(MLIST[[mm]]))
      )
      if (mm %in% c("psi", "theta")) {
        # remove duplicated columns of symmetric matrices
        idx <- lav_matrix_vechru_idx(sqrt(ncol(DX2)), diagonal = FALSE)
        if (length(idx) > 0L) DX2 <- DX2[, -idx]
      }
      cat(
        "[GW   ] mm = ", sprintf("%-8s:", mm), "sum delta = ",
        sprintf("%12.9f", sum(DX1 - DX2)), "  max delta = ",
        sprintf("%12.9f", max(DX1 - DX2)), "\n"
      )
      if (lav_debug()) {
        cat("[GW   ] mm = ", sprintf("%-8s:", mm), "DX1 (numerical):\n")
        print(DX1)
        cat("\n\n")
        cat("[GW   ] mm = ", sprintf("%-8s:", mm), "DX2 (analytical):\n")
        print(DX2)
        cat("\n\n")
      }
    }
  }

  MLIST$th.idx <- th.idx
  MLIST$num.idx <- num.idx

  MLIST
}

# check for marker indicators:
#   - if std.lv = FALSE: a single '1' per factor, everything else zero
#   - if std.lv = TRUE: a single non-zero value per factor, everything else zero
lav_utils_get_marker <- function(LAMBDA = NULL, std.lv = FALSE) {
  LAMBDA <- as.matrix(LAMBDA)
  nvar <- nrow(LAMBDA)
  nfac <- ncol(LAMBDA)

  # round values
  LAMBDA <- round(LAMBDA, 3L)

  marker.idx <- numeric(nfac)
  for (f in seq_len(nfac)) {
    if (std.lv) {
      marker.idx[f] <- which(rowSums(cbind(
        LAMBDA[, f] != 0,
        LAMBDA[, -f] == 0
      )) == nfac)[1]
    } else {
      marker.idx[f] <- which(rowSums(cbind(
        LAMBDA[, f] == 1,
        LAMBDA[, -f] == 0
      )) == nfac)[1]
    }
  }

  marker.idx
}

# find the residual variances (diagonal element of PSI) in such a way
# so that the diagonal elements of IB.inv %*% PSI %*% t(IB.inv) are
# equal to the elements of target.psi (usually the 1 vector)
#
# YR 01 Nov 2024: initial version; no bounds for now... (so we may end up
#                 with negative variances)
lav_mlist_target_psi <- function(BETA = NULL, IB.inv = NULL, PSI = NULL,
                                     target.psi = NULL, y.idx = NULL) {

  nr <- nrow(PSI)

  # IB.inv (if not given)
  if (is.null(IB.inv)) {
    IB <- -BETA
    IB[lav_matrix_diag_idx(nr)] <- 1
    IB.inv <- solve(IB)
  }

  # target.psi
  if (is.null(target.psi)) {
    target.psi <- rep(1, nr)
  }

  # y.idx
  if (is.null(y.idx)) {
    y.idx <- seq_len(nr)
  }

  # cast the problem as a nonlinear optimization problem
  obj <- function(x) {
    #cat("x = ", x, "\n")
    # x are the diagonal elements of PSI
    this.PSI <- PSI
    diag(this.PSI)[y.idx] <- x
    VETA <- IB.inv %*% this.PSI %*% t(IB.inv)
    current.diag <- diag(VETA)
    # ratio or difference?
    diff <- target.psi[y.idx] - current.diag[y.idx]
    out <- sum(diff * diff) # least squares
    out
  }

  VETA <- IB.inv %*% PSI %*% t(IB.inv)
  x.start <- diag(VETA)[y.idx]
  out <- nlminb(start = x.start, objective = obj)

  # return updated PSI matrix
  diag(PSI)[y.idx] <- out$par
  PSI
}

# get 'test'
# make sure we return a single element
lav_utils_get_test <- function(lavobject) {
  test <- lavobject@Options$test
  # 0.6.5: for now, we make sure that 'test' is a single element
  if (length(test) > 1L) {
    standard.idx <- which(test == "standard")
    if (length(standard.idx) > 0L) {
      test <- test[-standard.idx]
    }
    if (length(test) > 1L) {
      # only retain the first one
      test <- test[1]
    }
  }

  test
}


# inspect a fitted lavaan object

# backward compatibility -- wrapper around lavInspect
lav_lavaan_inspect <- function(object, what = "free", ...) {
  dotdotdot <- list(...)
  if (length(dotdotdot) > 0L) {
    for (j in seq_along(dotdotdot)) {
      lav_msg_warn(gettextf(
        "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
        sQuote("inspect"))
      )
    }
  }
  lav_lavaan_lavinspect(object              = object,
    what                   = what,
    add.labels             = TRUE,
    add.class              = TRUE,
    drop.list.single.group = TRUE)
}

# the `tech' version: no labels, full matrices, ... for further processing
lav_lavaan_lavtech <- function(object,
                           what                   = "free",
                           add.labels             = FALSE,
                           add.class              = FALSE,
                           list.by.group          = FALSE,
                           drop.list.single.group = FALSE) {

  lav_lavaan_lavinspect(object, what = what,
    add.labels = add.labels, add.class = add.class,
    list.by.group = list.by.group,
    drop.list.single.group =  drop.list.single.group)
}

# the `user' version: with defaults for display only
lav_lavaan_lavinspect <- function(object,                                # nolint
                              what                   = "free",
                              add.labels             = TRUE,
                              add.class              = TRUE,
                              list.by.group          = TRUE,
                              drop.list.single.group = TRUE) {
  # object must inherit from class lavaan
  stopifnot(inherits(object, "lavaan"))

  # check object
  object <- lav_object_check_version(object)

  # store partable with pta in object to use cache in called functions
  object@ParTable <- lav_partable_set_cache(object@ParTable, object@pta)

  # only a single argument
  if (length(what) > 1) {
    lav_msg_stop(gettextf("argument %s cannot have more than one element",
                          "what"))
  }

  # be case insensitive
  what <- tolower(what)

  #### model matrices, with different contents ####
  if (what == "free") {
    lav_object_inspect_modelmatrices(object, what = "free",
      type = "free", add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "impute" ||
    what == "imputed") { # just to ease the transition for semTools!
    object@imputed
  } else if (what == "partable" || what == "user") {
    lav_object_inspect_modelmatrices(object, what = "free",
      type = "partable", add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "se" ||
    what == "std.err" ||
    what == "standard.errors") {
    lav_object_inspect_modelmatrices(object, what = "se",
      add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "se.std" ||
    what == "std.se") {
    lav_object_inspect_modelmatrices(object, what = "std.se",
      add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "start" || what == "starting.values") {
    lav_object_inspect_modelmatrices(object, what = "start",
      add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "est"  || what == "estimates" ||
    what == "x") {
    lav_object_inspect_modelmatrices(object, what = "est",
      add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "est.unrotated") {
    lav_object_inspect_modelmatrices(object, what = "est.unrotated",
      add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "dx.free") {
    lav_object_inspect_modelmatrices(object, what = "dx.free",
      add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "dx.all") {
    lav_object_inspect_modelmatrices(object, what = "dx.all",
      add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "std" || what == "std.all" ||
    what == "est.std" || what == "std.est" ||
    what == "standardized") {
    lav_object_inspect_modelmatrices(object, what = "std.all",
      add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "std.lv") {
    lav_object_inspect_modelmatrices(object, what = "std.lv",
      add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "std.nox") {
    lav_object_inspect_modelmatrices(object, what = "std.nox",
      add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group)


    #### parameter table ####
  } else if (what == "list") {
    parTable(object)

    #### bootstrap coef ####
  } else if (what %in% c("boot", "bootstrap", "boot.coef", "coef.boot")) {
    lav_object_inspect_boot(object, add.labels = add.labels,
      add.class = add.class)

    #### fit indices ####
  } else if (what == "fit" ||
    what == "fitmeasures" ||
    what == "fit.measures" ||
    what == "fit.indices") {
    fitMeasures(object)

    #### baseline model ####
  } else if (what == "baseline.partable") {
    out <- as.data.frame(object@baseline$partable, stringsAsFactors = FALSE)
    if (add.class) {
      class(out) <- c("lavaan.data.frame", "data.frame")
    }
    return(out)
  } else if (what == "baseline.test") {
    object@baseline$test

    #### modification indices ####
  } else if (what == "mi" ||
    what == "modindices" ||
    what == "modification.indices") {
    modificationIndices(object)


    #### sample statistics #####
  } else if (what == "obs" ||
    what == "observed" ||
    what == "sampstat" ||
    what == "sampstats" ||
    what == "samplestats" ||
    what == "samp" ||
    what == "sample" ||
    what == "samplestatistics") {
    # new in 0.6-3: always use h1 = TRUE!!!
    lav_object_inspect_sampstat(object, h1 = TRUE, std = FALSE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "obs.std" ||
    what == "observed.std" ||
    what == "sampstat.std" ||
    what == "sampstats.std" ||
    what == "samplestats.std" ||
    what == "samp.std" ||
    what == "sample.std" ||
    what == "samplestatistics.std") {
    lav_object_inspect_sampstat(object, h1 = TRUE, std = TRUE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "h1" || what == "missing.h1" || what == "sampstat.h1") {
    lav_object_inspect_sampstat(object, h1 = TRUE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)

    #### wls.est - wls.obs - wls.v ####
  } else if (what == "wls.est") {
    lav_object_inspect_wls_est(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "wls.obs") {
    lav_object_inspect_wls_obs(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "wls.v") {
    lav_object_inspect_wls_v(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)



    #### data + missingness ####
  } else if (what == "data") {
    lav_object_inspect_data(object, add.labels = add.labels,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "case.idx") {
    lav_object_inspect_case_idx(object,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "ngroups") {
    object@Data@ngroups
  } else if (what == "group") {
    object@Data@group
  } else if (what == "cluster") {
    object@Data@cluster
  } else if (what == "nlevels") {
    object@Data@nlevels
  } else if (what == "nclusters") {
    lav_object_inspect_cluster_info(object, level = 2L,
      what = "nclusters",
      drop.list.single.group = drop.list.single.group)
  } else if (what == "ncluster.size") {
    lav_object_inspect_cluster_info(object, level = 2L,
      what = "ncluster.size",
      drop.list.single.group = drop.list.single.group)
  } else if (what == "cluster.size") {
    lav_object_inspect_cluster_info(object, level = 2L,
      what = "cluster.size",
      drop.list.single.group = drop.list.single.group)
  } else if (what == "cluster.id") {
    lav_object_inspect_cluster_info(object, level = 2L,
      what = "cluster.id",
      drop.list.single.group = drop.list.single.group)
  } else if (what == "cluster.idx") {
    lav_object_inspect_cluster_info(object, level = 2L,
      what = "cluster.idx",
      drop.list.single.group = drop.list.single.group)
  } else if (what == "cluster.label") {
    lav_object_inspect_cluster_info(object, level = 2L,
      what = "cluster.label",
      drop.list.single.group = drop.list.single.group)
  } else if (what == "cluster.sizes") {
    lav_object_inspect_cluster_info(object, level = 2L,
      what = "cluster.sizes",
      drop.list.single.group = drop.list.single.group)
  } else if (what == "average.cluster.size") {
    lav_object_inspect_cluster_info(object, level = 2L,
      what = "average.cluster.size",
      drop.list.single.group = drop.list.single.group)
  } else if (what == "ordered") {
    object@Data@ordered
  } else if (what == "group.label") {
    object@Data@group.label
  } else if (what == "level.label") {
    object@Data@level.label
  } else if (what == "nobs") {
    unlist(object@Data@nobs)
  } else if (what == "norig") {
    unlist(object@Data@norig)
  } else if (what == "ntotal") {
    sum(unlist(object@Data@nobs))
  } else if (what == "coverage") {
    lav_object_inspect_missing_coverage(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what %in% c("patterns", "pattern")) {
    lav_object_inspect_missing_patterns(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "empty.idx") {
    lav_object_inspect_empty_idx(object,
      drop.list.single.group = drop.list.single.group)


    #### rsquare ####
  } else if (what == "rsquare" || what == "r-square" || what == "r2") {
    lav_object_inspect_rsquare(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)


    #### model-implied sample statistics ####
  } else if (what == "implied" || what == "fitted" ||
    what == "expected" || what == "exp") {
    lav_object_inspect_implied(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "resid" || what == "res" || what == "residual" ||
    what == "residuals") {
    lav_object_inspect_residuals(object, h1 = TRUE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "cov.lv" || what == "veta") {
    lav_object_inspect_cov_lv(object,
      correlation.metric = FALSE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "cor.lv") {
    lav_object_inspect_cov_lv(object,
      correlation.metric = TRUE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "mean.lv" || what == "eeta") {
    lav_object_inspect_mean_lv(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "cov.all") {
    lav_object_inspect_cov_all(object,
      correlation.metric = FALSE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "cor.all") {
    lav_object_inspect_cov_all(object,
      correlation.metric = TRUE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "cov.ov" || what == "sigma" || what == "sigma.hat") {
    lav_object_inspect_cov_ov(object,
      correlation.metric = FALSE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "cor.ov") {
    lav_object_inspect_cov_ov(object,
      correlation.metric = TRUE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "mean.ov" || what == "mu" || what == "mu.hat") {
    lav_object_inspect_mean_ov(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "th" || what == "thresholds") {
    lav_object_inspect_th(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "th.idx") {
    lav_object_inspect_th_idx(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "vy") {
    lav_object_inspect_vy(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what %in% c("fs.reliability", "fs.rel", "fs.reliabilities")) {
    lav_object_inspect_fs_determinacy(object, squared = TRUE,
      fs.method = "regression",
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what %in% c("fs.determinacy", "fs.det", "fs.determin",
                         "fs.determinacies")) {
    lav_object_inspect_fs_determinacy(object, squared = FALSE,
      fs.method = "regression",
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what %in% c("fs.reliability.bartlett",
                         "fs.reliability.Bartlett",
                         "fs.rel.bartlett", "fs.rel.Bartlett",
                         "fs.reliabilities.bartlett",
                         "fs.reliabilities.Bartlett")) {
    lav_object_inspect_fs_determinacy(object, squared = TRUE,
      fs.method = "Bartlett",
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what %in% c("fs.determinacy.bartlett",
                         "fs.determinacy.Bartlett",
                         "fs.det.bartlett", "fs.det.Bartlett",
                         "fs.determin.bartlett", "fs.determin.Bartlett",
                         "fs.determinacies.bartlett",
                         "fs.determinacies.Bartlett")) {
    lav_object_inspect_fs_determinacy(object, squared = FALSE,
      fs.method = "Bartlett",
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)



    #### specific model matrices? ####
  } else if (what == "theta" || what == "theta.cov") {
    lav_object_inspect_theta(object,  correlation.metric = FALSE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "theta.cor") {
    lav_object_inspect_theta(object,  correlation.metric = TRUE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)

    #### (squared) Mahalanobis distances ####
  } else if (what == "mdist2.fs") {
    lav_object_inspect_mdist2(object, type = "lv", squared = TRUE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "mdist2.resid") {
    lav_object_inspect_mdist2(object, type = "resid", squared = TRUE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "mdist.fs") {
    lav_object_inspect_mdist2(object, type = "lv", squared = FALSE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "mdist.resid") {
    lav_object_inspect_mdist2(object, type = "resid", squared = FALSE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)

    #### convergence, meanstructure, categorical ####
  } else if (what == "converged") {
    object@optim$converged
  } else if (what == "iterations" ||
    what == "iter" ||
    what == "niter") {
    object@optim$iterations
  } else if (what == "meanstructure") {
    object@Model@meanstructure
  } else if (what == "categorical") {
    object@Model@categorical
  } else if (what == "fixed.x") {
    object@Model@fixed.x
  } else if (what == "parameterization") {
    object@Model@parameterization
  } else if (what == "npar") {
    lav_object_inspect_npar(object, ceq = FALSE) # ignore equality constraints
  } else if (what == "coef") {
    # this breaks simsem and semTools -- 0.6-1
    # lav_object_inspect_coef(object, type = "free",
    #                        add.labels = add.labels, add.class = add.class)
    lav_object_inspect_modelmatrices(object, what = "est",
      type = "free", add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group)


    #### NACOV samplestats ####
  } else if (what == "gamma") {
    lav_object_inspect_sampstat_gamma(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)


    #### gradient, Hessian, information, first.order, vcov ####
  } else if (what == "gradient") {
    lav_object_inspect_gradient(object,
      add.labels = add.labels, add.class = add.class, logl = FALSE)
  } else if (what == "gradient.logl") {
    lav_object_inspect_gradient(object,
      add.labels = add.labels, add.class = add.class, logl = TRUE)
  } else if (what == "optim.gradient") {
    lav_object_inspect_gradient(object,
      add.labels = add.labels, add.class = add.class, optim = TRUE)
  } else if (what == "hessian") {
    lav_object_inspect_hessian(object,
      add.labels = add.labels, add.class = add.class)

  } else if (what == "information") {
    lav_object_inspect_information(object, information = "default",
      augmented = FALSE, inverted = FALSE,
      add.labels = add.labels, add.class = add.class)
  } else if (what == "information.expected") {
    lav_object_inspect_information(object, information = "expected",
      augmented = FALSE, inverted = FALSE,
      add.labels = add.labels, add.class = add.class)
  } else if (what == "information.observed") {
    lav_object_inspect_information(object, information = "observed",
      augmented = FALSE, inverted = FALSE,
      add.labels = add.labels, add.class = add.class)
  } else if (what == "information.first.order" ||
    what == "information.firstorder"  ||
    what == "first.order") {
    lav_object_inspect_information(object, information = "first.order",
      augmented = FALSE, inverted = FALSE,
      add.labels = add.labels, add.class = add.class)

  } else if (what == "augmented.information") {
    lav_object_inspect_information(object, information = "default",
      augmented = TRUE, inverted = FALSE,
      add.labels = add.labels, add.class = add.class)
  } else if (what == "augmented.information.expected") {
    lav_object_inspect_information(object, information = "expected",
      augmented = TRUE, inverted = FALSE,
      add.labels = add.labels, add.class = add.class)
  } else if (what == "augmented.information.observed") {
    lav_object_inspect_information(object, information = "observed",
      augmented = TRUE, inverted = FALSE,
      add.labels = add.labels, add.class = add.class)
  } else if (what == "augmented.information.first.order" ||
    what == "augmented.first.order") {
    lav_object_inspect_information(object, information = "first.order",
      augmented = TRUE, inverted = FALSE,
      add.labels = add.labels, add.class = add.class)

  } else if (what == "inverted.information") {
    lav_object_inspect_information(object, information = "default",
      augmented = TRUE, inverted = TRUE,
      add.labels = add.labels, add.class = add.class)
  } else if (what == "inverted.information.expected") {
    lav_object_inspect_information(object, information = "expected",
      augmented = TRUE, inverted = TRUE,
      add.labels = add.labels, add.class = add.class)
  } else if (what == "inverted.information.observed") {
    lav_object_inspect_information(object, information = "observed",
      augmented = TRUE, inverted = TRUE,
      add.labels = add.labels, add.class = add.class)
  } else if (what == "inverted.information.first.order" ||
    what == "inverted.first.order") {
    lav_object_inspect_information(object, information = "first.order",
      augmented = TRUE, inverted = TRUE,
      add.labels = add.labels, add.class = add.class)

  } else if (what == "h1.information") {
    lav_object_inspect_h1_information(object, information = "default",
      h1.information = "default", inverted = FALSE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "h1.information.expected") {
    lav_object_inspect_h1_information(object, information = "expected",
      h1.information = "default", inverted = FALSE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "h1.information.observed") {
    lav_object_inspect_h1_information(object, information = "observed",
      h1.information = "default", inverted = FALSE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "h1.information.first.order" ||
    what == "h1.information.firstorder"  ||
    what == "h1.first.order") {
    lav_object_inspect_h1_information(object,
      information = "first.order", h1.information = "default",
      inverted = FALSE, add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)

  } else if (what == "vcov") {
    lav_object_inspect_vcov(object,
      standardized = FALSE,
      add.labels = add.labels, add.class = add.class)
  } else if (what == "vcov.std.all" || what == "vcov.standardized" ||
    what == "vcov.std") {
    lav_object_inspect_vcov(object,
      standardized = TRUE, type = "std.all",
      add.labels = add.labels, add.class = add.class)
  } else if (what == "vcov.std.lv") {
    lav_object_inspect_vcov(object,
      standardized = TRUE, type = "std.lv",
      add.labels = add.labels, add.class = add.class)
  } else if (what == "vcov.std.nox") {
    lav_object_inspect_vcov(object,
      standardized = TRUE, type = "std.nox",
      add.labels = add.labels, add.class = add.class)

  } else if (what == "vcov.def") {
    lav_object_inspect_vcov_def(object, joint = FALSE,
      standardized = FALSE,
      add.labels = add.labels, add.class = add.class)
  } else if (what == "vcov.def.std.all" || what == "vcov.def.standardized" ||
    what == "vcov.def.std") {
    lav_object_inspect_vcov_def(object, joint = FALSE,
      standardized = TRUE, type = "std.all",
      add.labels = add.labels, add.class = add.class)
  } else if (what == "vcov.def.std.lv") {
    lav_object_inspect_vcov_def(object, joint = FALSE,
      standardized = TRUE, type = "std.lv",
      add.labels = add.labels, add.class = add.class)
  } else if (what == "vcov.def.std.nox") {
    lav_object_inspect_vcov_def(object, joint = FALSE,
      standardized = TRUE, type = "std.nox",
      add.labels = add.labels, add.class = add.class)

  } else if (what == "vcov.def.joint") {
    lav_object_inspect_vcov_def(object, joint = TRUE,
      standardized = FALSE,
      add.labels = add.labels, add.class = add.class)
  } else if (what == "vcov.def.joint.std.all" ||
    what == "vcov.def.joint.standardized" ||
    what == "vcov.def.joint.std") {
    lav_object_inspect_vcov_def(object, joint = TRUE,
      standardized = TRUE, type = "std.all",
      add.labels = add.labels, add.class = add.class)
  } else if (what == "vcov.def.joint.std.lv") {
    lav_object_inspect_vcov_def(object, joint = TRUE,
      standardized = TRUE, type = "std.lv",
      add.labels = add.labels, add.class = add.class)
  } else if (what == "vcov.def.joint.std.nox") {
    lav_object_inspect_vcov_def(object, joint = TRUE,
      standardized = TRUE, type = "std.nox",
      add.labels = add.labels, add.class = add.class)

  } else if (what == "ugamma" || what == "ug" || what == "u.gamma") {
    lav_object_inspect_UGamma(object,
      add.labels = add.labels, add.class = add.class)
  } else if (what == "ufromugamma" || what == "u") {
    lav_object_inspect_UfromUGamma(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)

    ### jacobians ####
  } else if (what == "delta") {
    lav_object_inspect_delta(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "delta.rownames") {
    lav_object_inspect_delta_rownames(object,
      drop.list.single.group = drop.list.single.group)

    ### casewise loglikehoods ###
  } else if (what == "loglik.casewise") {
    lav_object_inspect_loglik_casewise(object, log. = TRUE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "lik.casewise") {
    lav_object_inspect_loglik_casewise(object, log. = FALSE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)

    # multilevel #
  } else if (what == "icc") {
    lav_object_inspect_icc(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)
  } else if (what == "ranef") {
    lav_object_inspect_ranef(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)

    # instrumental variables
  } else if(what %in% c("iv", "ivs", "miiv", "miivs", "instr", "instruments")) {
    lav_object_inspect_iv(object,
      drop.list.single.group = drop.list.single.group)
  } else if(what %in% c("eqs")) {
    lav_object_inspect_eqs(object,
      drop.list.single.group = drop.list.single.group)
  } else if(what %in% c("sargan")) {
    lav_object_inspect_sargan(object,
      drop.list.single.group = drop.list.single.group)

    # post-checking
  } else if (what == "post.check" || what == "post") {
    lav_object_post_check(object)

    # options
  } else if (what == "options" || what == "lavoptions") {
    object@Options

    # version
  } else if (what == "version") {
    object@version

    # call
  } else if (what == "call") {
    as.list(object@call)

    # timing
  } else if (what == "timing") {
    object@timing

    # optim
  } else if (what == "optim") {
    object@optim

    # test
  } else if (what == "test") {
    object@test

    # zero cell tables
  } else if (what == "zero.cell.tables") {
    lav_object_inspect_zero_cell_tables(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group)

    #### not found ####
  } else {
    lav_msg_stop(gettextf(
      "%1$s argument unknown: %2$s",
      "what", lav_msg_view(what)
    ))
  }

}


# helper functions (mostly to deal with older 'object' that may have
# been saved somewhere)
lav_object_inspect_est <- function(object, unrotated = FALSE) {

  if (inherits(object, "lavaan")) {
    # from 0.5-19, they are in the partable
    if (!is.null(object@ParTable$est)) {
      if (unrotated) {
        return.value <- object@ParTable$est.unrotated
      } else {
        return.value <- object@ParTable$est # if this changes, tag @TDJorgensen in commit message
      }
    } else {
      partable <- parTable(object)
      return.value <- rep(as.numeric(NA), length(partable$lhs))
    }
  } else {
    # try generic coef()
    return.value <- coef(object, type = "user")
    if (is.matrix(return.value)) {
      # lavaanList?
      return.value <- rowMeans(return.value)
    }
  }

  return.value
}

lav_object_inspect_se <- function(object) {
  # from 0.5-19, they are in the partable
  if (!is.null(object@ParTable$se)) {
    return.value <- object@ParTable$se
  } else {
    partable <- parTable(object)
    return.value <- rep(as.numeric(NA), length(partable$lhs))
  }

  return.value
}

lav_object_inspect_std_se <- function(object) {

  if (!is.null(object@ParTable$se.std)) {
    return.value <- object@ParTable$se.std
  } else {
    tmp.std <- standardizedSolution(object)
    return.value <- tmp.std$se
  }

  return.value
}

lav_object_inspect_start <- function(object) {
  # from 0.5-19, they are in the partable
  if (!is.null(object@ParTable$start)) {
    return.value <- object@ParTable$start
  } else {
    # in < 0.5-19, we should look in @Fit@start
    return.value <- object@Fit@start
  }

  return.value
}

lav_object_inspect_boot <- function(object, add.labels = FALSE,
                                    add.class = FALSE) {

  if (object@Options$se   != "bootstrap" &&
    !any(c("bootstrap", "bollen.stine") %in% object@Options$test)) {
    lav_msg_stop(gettext("bootstrap was not used."))
  }

  # from 0.5-19. they are in a separate slot
  tmp <- try(slot(object, "boot"), silent = TRUE)
  if (inherits(tmp, "try-error")) {
    # older version of object?
    est <- lav_object_inspect_est(object)
    tmp.boot <- attr(est, "tmp.boot.COEF")
  } else {
    # 0.5-19 way
    tmp.boot <- object@boot$coef
  }

  # add coef names
  if (add.labels) {
    colnames(tmp.boot) <- names(coef(object))
  }

  # add class
  if (add.class) {
    class(tmp.boot) <- c("lavaan.matrix", "matrix")
  }

  tmp.boot
}


lav_object_inspect_modelmatrices <- function(object, what = "free", # nolint
    type = "free", add.labels = FALSE, add.class = FALSE,
    list.by.group = FALSE,
    drop.list.single.group = FALSE) {

  glist <- object@Model@GLIST

  current.verbose <- lav_verbose()
  if (what == "dx.free") {
    if (lav_verbose(FALSE)) on.exit(lav_verbose(current.verbose), TRUE)
    tmp.dx <- lav_model_gradient(
      lavmodel       = object@Model,
      GLIST          = NULL,
      lavsamplestats = object@SampleStats,
      lavdata        = object@Data,
      lavcache       = object@Cache,
      type           = "free",
      group.weight   = TRUE,
      ceq.simple     = TRUE,
      Delta          = NULL)
  } else if (what == "dx.all") {
    if (lav_verbose(FALSE)) on.exit(lav_verbose(current.verbose), TRUE)
    glist <- lav_model_gradient(lavmodel   = object@Model,
      GLIST          = NULL,
      lavsamplestats = object@SampleStats,
      lavdata        = object@Data,
      lavcache       = object@Cache,
      type           = "allofthem",
      group.weight   = TRUE,
      ceq.simple     = FALSE,
      Delta          = NULL)
    names(glist) <- names(object@Model@GLIST)
  } else if (what == "std.all") {
    tmp.std <- lav_standardize_all(object)
  } else if (what == "std.lv") {
    tmp.std <- lav_standardize_lv(object)
  } else if (what == "std.nox") {
    tmp.std <- lav_standardize_all_nox(object)
  } else if (what == "se") {
    tmp.se <- lav_object_inspect_se(object)
  } else if (what == "std.se") {
    tmp.se <- lav_object_inspect_std_se(object)
  } else if (what == "start") {
    tmp.start <- lav_object_inspect_start(object)
  } else if (what == "est") {
    tmp.est <- lav_object_inspect_est(object)
  } else if (what == "est.unrotated") {
    if (!is.null(object@Options$rotation) &&
      object@Options$rotation == "none") {
      tmp.est <- lav_object_inspect_est(object, unrotated = FALSE)
    } else {
      tmp.est <- lav_object_inspect_est(object, unrotated = TRUE)
    }
  }

  for (mm in seq_along(glist)) {

    if (add.labels) {
      dimnames(glist[[mm]]) <- object@Model@dimNames[[mm]]
    }

    if (what == "free") {
      # fill in free parameter counts
      if (type == "free") {
        m.el.idx <- object@Model@m.free.idx[[mm]]
        x.el.idx <- object@Model@x.free.idx[[mm]]
        # } else if(type == "unco") {
        #    m.el.idx <- object@Model@m.unco.idx[[mm]]
        #    x.el.idx <- object@Model@x.unco.idx[[mm]]
      } else if (type == "partable") {
        m.el.idx <- object@Model@m.user.idx[[mm]]
        x.el.idx <- object@Model@x.user.idx[[mm]]
      } else {
        lav_msg_stop(gettextf(
          "%1$s argument unknown: %2$s",
          "type", lav_msg_view(type)
        ))
      }
      # erase everything
      glist[[mm]][, ] <- 0.0
      glist[[mm]][m.el.idx] <- x.el.idx
    } else if (what == "se" || what == "std.se") {
      # fill in standard errors
      m.user.idx <- object@Model@m.user.idx[[mm]]
      x.user.idx <- object@Model@x.user.idx[[mm]]
      # erase everything
      glist[[mm]][, ] <- 0.0
      glist[[mm]][m.user.idx] <- tmp.se[x.user.idx]
    } else if (what == "start") {
      # fill in starting values
      m.user.idx <- object@Model@m.user.idx[[mm]]
      x.user.idx <- object@Model@x.user.idx[[mm]]
      glist[[mm]][m.user.idx] <- tmp.start[x.user.idx]
    } else if (what %in% c("est", "est.unrotated")) {
      # fill in estimated parameter values
      m.user.idx <- object@Model@m.user.idx[[mm]]
      x.user.idx <- object@Model@x.user.idx[[mm]]
      glist[[mm]][m.user.idx] <- tmp.est[x.user.idx]
    } else if (what == "dx.free") {
      # fill in derivatives free parameters
      m.el.idx <- object@Model@m.free.idx[[mm]]
      x.el.idx <- object@Model@x.free.idx[[mm]]
      # erase everything
      glist[[mm]][, ] <- 0.0
      glist[[mm]][m.el.idx] <- tmp.dx[x.el.idx]
    } else if (what %in% c("std.all", "std.lv", "std.nox")) {
      m.user.idx <- object@Model@m.user.idx[[mm]]
      x.user.idx <- object@Model@x.user.idx[[mm]]
      glist[[mm]][m.user.idx] <- tmp.std[x.user.idx]
    }

    # class
    if (add.class) {
      if (object@Model@isSymmetric[mm]) {
        class(glist[[mm]]) <- c("lavaan.matrix.symmetric", "matrix")
      } else {
        class(glist[[mm]]) <- c("lavaan.matrix", "matrix")
      }
    }
  }

  # try to reflect `equality constraints'
  con.flag <- FALSE
  if (what == "free" && object@Model@eq.constraints) {
    # extract constraints from parameter table
    partable <- parTable(object)
    tmp.con <-  partable[partable$op %in% c("==", "<", ">"),
                         c("lhs", "op", "rhs")]
    rownames(tmp.con) <- NULL

    # replace 'labels' by parameter numbers
    tmp.id <- lav_partable_constraints_label_id(partable)
    tmp.label <- names(tmp.id)
    for (con in seq_len(nrow(tmp.con))) {
      # lhs
      lhs.labels <- all.vars(as.formula(paste("~", tmp.con[con, "lhs"])))

      if (length(lhs.labels) > 0L) {
        # par id
        lhs.freeid <- tmp.id[match(lhs.labels, tmp.label)]

        # substitute
        tmp <- tmp.con[con, "lhs"]
        for (pat in seq_along(lhs.labels)) {
          tmp <- sub(lhs.labels[pat], lhs.freeid[pat], tmp)
        }
        tmp.con[con, "lhs"] <- tmp
      }

      # rhs
      rhs.labels <- all.vars(as.formula(paste("~", tmp.con[con, "rhs"])))

      if (length(rhs.labels) > 0L) {
        # par id
        rhs.freeid <- tmp.id[match(rhs.labels, tmp.label)]
        # substitute
        tmp <- tmp.con[con, "rhs"]
        for (pat in seq_along(rhs.labels)) {
          tmp <- sub(rhs.labels[pat], rhs.freeid[pat], tmp)
        }
        tmp.con[con, "rhs"] <- tmp
      }
    } # con

    # add this info at the top
    # glist <- c(constraints = list(tmp.con), glist)
    # no, not a good idea, it does not work with list.by.group

    # add it as a 'header' attribute?
    attr(tmp.con, "header") <- "Note: model contains equality constraints:"
    con.flag <- TRUE
  }

  # should we group them per block?
  if (list.by.group) {
    lavmodel       <- object@Model
    nmat           <- lavmodel@nmat

    return.value <- vector("list", length = lavmodel@nblocks)
    for (b in seq_len(lavmodel@nblocks)) {
      # which mm belong to this block?
      mm.in.group <- 1:nmat[b] + cumsum(c(0, nmat))[b]

      return.value[[b]] <- glist[mm.in.group]
    }

    if (lavmodel@nblocks == 1L && drop.list.single.group) {
      return.value <- return.value[[1]]
    } else if (lavmodel@nblocks > 1L) {
      names(return.value) <- object@Data@block.label
    }
  } else {
    return.value <- glist
  }

  # header
  if (con.flag) {
    attr(return.value, "header") <- tmp.con
  }

  # lavaan.list
  if (add.class) {
    class(return.value) <- c("lavaan.list", "list")
  }

  return.value
}




# - fixme, should we export this function?
# - since 0.5-21, conditional.x = TRUE returns residual sample statistics
#    for ML, we have both joint and residual cov/var/...; but for
#    categorical = TRUE, we only have residual cov/var...; so, we
#    only return residual in both cases, whenever residual
# - since 0.6-3, we always extract the values from the @h1 slot (if present)
#   if meanstructure = FALSE, do NOT include $mean elements any longer
lav_object_inspect_sampstat <- function(object, h1 = TRUE,        # nolint
    std = FALSE,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  nblocks <- object@Model@nblocks
  ov.names <- object@pta$vnames$ov
  ov.names.res <- object@pta$vnames$ov.nox
  ov.names.x   <- object@pta$vnames$ov.x

  # slots
  lavsamplestats <- object@SampleStats
  lavmodel <- object@Model

  # if nlevels, override h1 to be TRUE, and set conditional.x = FALSE
  if (object@Data@nlevels > 1L) {
    h1 <- TRUE
    conditional.x <- FALSE # for now (0.6-12)
  } else {
    conditional.x <- lavmodel@conditional.x
  }

  # check if we have a non-empty @h1 slot
  if (length(object@h1) == 0L) {
    h1 <- FALSE
  } else {
    h1.implied <- object@h1$implied
  }

  # if h1 = FALSE and nlevels > 1L, nothing to show...
  if (!h1 && object@Data@nlevels > 1L) {
    lav_msg_stop(gettext(
      "sample statistics not available; refit with option h1 = TRUE"))
  }

  return.value <- vector("list", length = nblocks)
  for (b in seq_len(nblocks)) {

    if (!conditional.x) {
      # covariance matrix
      if (h1) {
        return.value[[b]]$cov  <- h1.implied$cov[[b]]
      } else {
        return.value[[b]]$cov  <- lavsamplestats@cov[[b]]
      }
      if (std) {
        diag.orig <- diag(return.value[[b]]$cov)
        return.value[[b]]$cov <- cov2cor(return.value[[b]]$cov)
      }
      if (add.labels && !is.null(return.value[[b]]$cov)) {
        rownames(return.value[[b]]$cov) <- colnames(return.value[[b]]$cov) <-
          ov.names[[b]]
      }
      if (add.class) {
        class(return.value[[b]]$cov) <- c("lavaan.matrix.symmetric", "matrix")
      }

      # mean vector
      if (lavmodel@meanstructure) {
        if (h1) {
          return.value[[b]]$mean <- as.numeric(h1.implied$mean[[b]])
        } else {
          return.value[[b]]$mean <- as.numeric(lavsamplestats@mean[[b]])
        }
        if (std) {
          diag.orig[diag.orig < .Machine$double.eps] <- NA
          return.value[[b]]$mean <- return.value[[b]]$mean / sqrt(diag.orig)
        }
        if (add.labels) {
          names(return.value[[b]]$mean) <- ov.names[[b]]
        }
        if (add.class) {
          class(return.value[[b]]$mean) <- c("lavaan.vector", "numeric")
        }
      }

      # thresholds
      if (lavmodel@categorical) {
        if (h1) {
          return.value[[b]]$th <- as.numeric(h1.implied$th[[b]])
        } else {
          return.value[[b]]$th <- as.numeric(lavsamplestats@th[[b]])
        }
        if (length(lavmodel@num.idx[[b]]) > 0L) {
          num.idx <- which(lavmodel@th.idx[[b]] == 0)
          return.value[[b]]$th <- return.value[[b]]$th[-num.idx]
        }
        # FIXME: what to do if std = TRUE (depends on delta/theta)
        if (add.labels) {
          names(return.value[[b]]$th) <- object@pta$vnames$th[[b]]
        }
        if (add.class) {
          class(return.value[[b]]$th) <- c("lavaan.vector", "numeric")
        }
      }
      # !conditional.x
    } else {
      # if conditional.x = TRUE

      # residual covariance matrix
      if (h1) {
        return.value[[b]]$res.cov  <- h1.implied$res.cov[[b]]
      } else {
        return.value[[b]]$res.cov  <- lavsamplestats@res.cov[[b]]
      }
      if (std) {
        diag.orig <- diag(return.value[[b]]$res.cov)
        return.value[[b]]$res.cov <- cov2cor(return.value[[b]]$res.cov)
      }
      if (add.labels) {
        rownames(return.value[[b]]$res.cov) <-
          colnames(return.value[[b]]$res.cov) <-
          ov.names.res[[b]]
      }
      if (add.class) {
        class(return.value[[b]]$res.cov) <-
          c("lavaan.matrix.symmetric", "matrix")
      }

      # intercepts
      if (lavmodel@meanstructure) {
        if (h1) {
          return.value[[b]]$res.int <- as.numeric(h1.implied$res.int[[b]])
        } else {
          return.value[[b]]$res.int <- as.numeric(lavsamplestats@res.int[[b]])
        }
        if (std) {
          diag.orig[diag.orig < .Machine$double.eps] <- NA
          return.value[[b]]$res.int <- return.value[[b]]$res.int /
            sqrt(diag.orig)
        }
        if (add.labels) {
          names(return.value[[b]]$res.int) <- ov.names.res[[b]]
        }
        if (add.class) {
          class(return.value[[b]]$res.int) <- c("lavaan.vector", "numeric")
        }
      }

      # thresholds
      if (lavmodel@categorical) {
        if (h1) {
          return.value[[b]]$res.th <- as.numeric(h1.implied$res.th[[b]])
        } else {
          return.value[[b]]$res.th <- as.numeric(lavsamplestats@res.th[[b]])
        }
        if (length(lavmodel@num.idx[[b]]) > 0L) {
          num.idx <- which(lavmodel@th.idx[[b]] == 0)
          return.value[[b]]$res.th <- return.value[[b]]$res.th[-num.idx]
        }
        # FIXME: if std: what to do?
        if (add.labels) {
          names(return.value[[b]]$res.th) <- object@pta$vnames$th[[b]]
        }
        if (add.class) {
          class(return.value[[b]]$res.th) <- c("lavaan.vector", "numeric")
        }
      }

      # slopes
      if (lavmodel@nexo[b] > 0L) {
        if (h1) {
          return.value[[b]]$res.slopes  <- h1.implied$res.slopes[[b]]
        } else {
          return.value[[b]]$res.slopes  <- lavsamplestats@res.slopes[[b]]
        }
        # FIXME: if std: what to do? (here: b.z = b * s.x /s.y)
        if (std) {
          tmp.y <- matrix(sqrt(diag.orig),
            nrow(return.value[[b]]$res.slopes),
            ncol(return.value[[b]]$res.slopes))
          tmp.x <- matrix(sqrt(diag(lavsamplestats@cov.x[[b]])),
            nrow(return.value[[b]]$res.slopes),
            ncol(return.value[[b]]$res.slopes), byrow = TRUE)
          return.value[[b]]$res.slopes <- return.value[[b]]$res.slopes /
                                          tmp.y * tmp.x
        }
        if (add.labels) {
          rownames(return.value[[b]]$res.slopes) <- ov.names.res[[b]]
          colnames(return.value[[b]]$res.slopes) <- ov.names.x[[b]]
        }
        if (add.class) {
          class(return.value[[b]]$res.slopes) <- c("lavaan.matrix", "matrix")
        }
      }

      # cov.x
      if (lavmodel@nexo[b] > 0L) {
        return.value[[b]]$cov.x  <- lavsamplestats@cov.x[[b]]
        if (std) {
          diag.orig <- diag(return.value[[b]]$cov.x)
          return.value[[b]]$cov.x <- cov2cor(return.value[[b]]$cov.x)
        }
        if (add.labels) {
          rownames(return.value[[b]]$cov.x) <- ov.names.x[[b]]
          colnames(return.value[[b]]$cov.x) <- ov.names.x[[b]]
        }
        if (add.class) {
          class(return.value[[b]]$cov.x) <-
            c("lavaan.matrix.symmetric", "matrix")
        }
      }

      # mean.x
      if (lavmodel@nexo[b] > 0L) {
        return.value[[b]]$mean.x <- as.numeric(object@SampleStats@mean.x[[b]])
        if (std) {
          diag.orig[diag.orig < .Machine$double.eps] <- NA
          return.value[[b]]$mean.x <- return.value[[b]]$mean.x / sqrt(diag.orig)
        }
        if (add.labels) {
          names(return.value[[b]]$mean.x) <- ov.names.x[[b]]
        }
        if (add.class) {
          class(return.value[[b]]$mean.x) <- c("lavaan.vector", "numeric")
        }
      }

    } # conditional.x

    # stochastic weights
    if (lavmodel@group.w.free) {
      # to be consistent with the 'implied' values,
      # transform so group.w is the 'log(group.freq)'
      return.value[[b]]$group.w <-
        log(lavsamplestats@group.w[[b]] * lavsamplestats@ntotal)
      if (add.labels) {
        names(return.value[[b]]$group.w) <- "w"
      }
      if (add.class) {
        class(return.value[[b]]$group.w) <- c("lavaan.vector", "numeric")
      }
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (nblocks > 1L) {
    names(return.value) <- object@Data@block.label
  }

  return.value
}


lav_object_inspect_data <- function(object, add.labels = FALSE,
                                    drop.list.single.group = FALSE) {

  n.g <- object@Data@ngroups
  if (object@Model@conditional.x) {
    return.value <- vector("list", length = n.g)
    for (g in 1:n.g) {
      return.value[[g]] <- cbind(object@Data@X[[g]],
        object@Data@eXo[[g]])
    }
  } else {
    return.value <- object@Data@X
  }

  if (add.labels) {
    for (g in 1:n.g) {
      if (object@Model@conditional.x) {
        colnames(return.value[[g]]) <- c(object@Data@ov.names[[g]],
          object@Data@ov.names.x[[g]])
      } else {
        colnames(return.value[[g]]) <- object@Data@ov.names[[g]]
      }
    }
  }

  if (n.g == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else {
    if (length(object@Data@group.label) > 0L) {
      names(return.value) <- unlist(object@Data@group.label)
    }
  }

  return.value
}

lav_object_inspect_case_idx <- function(object,
                                        drop.list.single.group = FALSE) {
  n.g <- object@Data@ngroups

  return.value <- object@Data@case.idx

  if (n.g == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else {
    if (length(object@Data@group.label) > 0L) {
      names(return.value) <- unlist(object@Data@group.label)
    }
  }

  return.value
}

# lav_object_inspect_case_idx <- function(object, level = 1L,
#                                        drop.list.single.group = FALSE) {
#    #FIXME: if lavaan ever allows 3-level or cross-classifed models,
#    #      "level=" should be a character indicating the clustering variable
#
#    n.g <- object@Data@ngroups
#    nlevels <- object@Data@nlevels
#    if (nlevels == 1L) level <- 1L
#                         # if what="cluster.idx" for single-level model
#
#    if (level == 2L) {
#        # level-2 (cluster) IDs
#        return.value <- lapply(object@Data@Lp, function(gg)
#                           gg$cluster.id[[2]][ gg$cluster.idx[[2]] ])
#        #FIXME: update if lavaan ever accepts 3-level or
#                                           cross-classified models
#
#    } else return.value <- object@Data@case.idx # level-1 (casewise) IDs
#
#    if(n.g == 1L && drop.list.single.group) {
#        return.value <- return.value[[1]]
#    } else {
#        if(length(object@Data@group.label) > 0L) {
#            names(return.value) <- unlist(object@Data@group.label)
#        }
#    }
#    return.value
# }
#

# cluster info
lav_object_inspect_cluster_info <- function(                # nolint
    object,
    what = "cluster.size",
    level = 2L,
    drop.list.single.group = FALSE) {

  n.g <- object@Data@ngroups
  nlevels <- object@Data@nlevels

  # just in case we have no clusters
  if (nlevels == 1L) {
    if (what %in% c("nclusters", "ncluster.size", "cluster.id")) {
      return.value <- as.list(rep(1L, n.g))
    } else if (what %in% c("cluster.size", "cluster.sizes")) {
      return.value <- object@Data@nobs
    } else if (what %in% c("cluster.idx", "cluster.label")) {
      # everybody belongs to cluster 1
      return.value <- lapply(seq_len(n.g),
        function(gg) rep(1L, object@Data@nobs[[gg]]))
    }
  }

  # if we do have clusters
  if (nlevels > 1L) {
    return.value <- vector("list", length = n.g)

    for (g in seq_len(n.g)) {
      tmp.lp <- object@Data@Lp[[g]]
      if (what == "nclusters") {
        return.value[[g]] <- tmp.lp$nclusters[[level]]
      } else if (what == "ncluster.size") {
        return.value[[g]] <- tmp.lp$ncluster.size[[level]]
      } else if (what == "cluster.size") {
        return.value[[g]] <- tmp.lp$cluster.size[[level]]
      } else if (what == "cluster.id") {
        return.value[[g]] <- tmp.lp$cluster.id[[level]]
      } else if (what == "cluster.idx") {
        return.value[[g]] <- tmp.lp$cluster.idx[[level]]
      } else if (what == "cluster.label") {
        return.value[[g]] <-
          tmp.lp$cluster.id[[level]][tmp.lp$cluster.idx[[level]]]
      } else if (what == "cluster.sizes") {
        return.value[[g]] <- tmp.lp$cluster.sizes[[level]]
      } else if (what == "average.cluster.size") {
        nn.g <- object@Data@nobs[[g]]
        cluster.size <- tmp.lp$cluster.size[[level]]
        nclusters <- tmp.lp$nclusters[[level]]
        return.value[[g]] <- (nn.g^2 - sum(cluster.size^2)) /
          (nn.g * (nclusters - 1L))
      }
    } # g
  } # nlevels > 1L

  if (n.g == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else {
    if (length(object@Data@group.label) > 0L) {
      names(return.value) <- unlist(object@Data@group.label)
    }
  }

  return.value
}


# count the number of clusters, or obtain tmp.n within each cluster
# lav_object_inspect_ncluster <- function(object, sizes = FALSE, #level = 2L,
#                                        drop.list.single.group = FALSE) {
#    n.g <- object@Data@ngroups
#    nlevels <- object@Data@nlevels
#
#    if (nlevels == 1L) {
#      # single-level model, return sample size(s) or count 1 cluster per group
#      return.value <- if (sizes) unlist(object@Data@nobs) else rep(1L, n.g)
#
#    } else if (sizes) {
#      # for each group, a vector of cluster sizes
#      return.value <- lapply(object@Data@Lp, function(gg) gg$cluster.size[[2]])
#      #FIXME: update if lavaan ever accepts 3-level or cross-classified models
#
#      if (n.g == 1L && drop.list.single.group)
#                       return.value <- return.value[[1]]
#
#    } else {
#      # number of clusters in each group
#      return.value <- sapply(object@Data@Lp, function(gg) gg$nclusters[[2]])
#      #FIXME: update if lavaan ever accepts 3-level or cross-classified models
#    }
#
#    # assign group names, if applicable
#    if (n.g > 1L) names(return.value) <- unlist(object@Data@group.label)
#    return.value
# }

lav_object_inspect_rsquare <- function(object, est.std.all = NULL,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  nblocks <- object@Model@nblocks
  return.value <- vector("list", length = nblocks)

  if (is.null(est.std.all)) {
    est.std.all <- lav_standardize_all(object)
  }

  partable <- object@ParTable
  partable$rsquare <- 1.0 - est.std.all
  # no values > 1.0
  partable$rsquare[partable$rsquare > 1.0] <- as.numeric(NA)

  for (b in seq_len(nblocks)) {
    ind.names <- partable$rhs[which(partable$op == "=~" &
      partable$block == b)]
    eqs.y.names <- partable$lhs[which(partable$op == "~"  &
      partable$block == b)]
    y.names <- unique(c(ind.names, eqs.y.names))

    idx <- which(partable$op == "~~" & partable$lhs %in% y.names &
      partable$rhs == partable$lhs & partable$block == b)
    tmp <- partable$rsquare[idx]

    if (add.labels && length(tmp) > 0L) {
      names(tmp) <- partable$lhs[idx]
    }
    if (add.class) {
      class(tmp) <- c("lavaan.vector", "numeric")
    }

    return.value[[b]] <- tmp
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (nblocks > 1L) {
    names(return.value) <- object@Data@block.label
  }

  return.value
}

# model implied sample stats
lav_object_inspect_implied <- function(object,                    # nolint
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  nblocks <- object@Model@nblocks
  ov.names <- object@pta$vnames$ov
  ov.names.res <- object@pta$vnames$ov.nox
  ov.names.x   <- object@pta$vnames$ov.x

  # slots
  lavimplied <- object@implied
  lavmodel   <- object@Model

  # if nlevels, always set conditional.x = FALSE
  if (object@Data@nlevels > 1L) {
    lavimplied <- lav_model_implied_cond2uncond(lavimplied)
    conditional.x <- FALSE # for now (0.6-12)
  } else {
    conditional.x <- lavmodel@conditional.x
  }

  return.value <- vector("list", length = nblocks)
  for (b in seq_len(nblocks)) {

    if (!conditional.x) {
      # covariance matrix
      return.value[[b]]$cov  <- lavimplied$cov[[b]]
      if (add.labels && !is.null(return.value[[b]]$cov)) {
        rownames(return.value[[b]]$cov) <- colnames(return.value[[b]]$cov) <-
          ov.names[[b]]
      }
      if (add.class) {
        class(return.value[[b]]$cov) <- c("lavaan.matrix.symmetric", "matrix")
      }

      # mean vector
      if (lavmodel@meanstructure) {
        return.value[[b]]$mean <- as.numeric(lavimplied$mean[[b]])
        if (add.labels) {
          names(return.value[[b]]$mean) <- ov.names[[b]]
        }
        if (add.class) {
          class(return.value[[b]]$mean) <- c("lavaan.vector", "numeric")
        }
      }

      # thresholds
      if (lavmodel@categorical) {
        return.value[[b]]$th <- as.numeric(lavimplied$th[[b]])
        if (length(object@Model@num.idx[[b]]) > 0L) {
          num.idx <- which(object@Model@th.idx[[b]] == 0)
          return.value[[b]]$th <- return.value[[b]]$th[-num.idx]
        }
        if (add.labels) {
          names(return.value[[b]]$th) <- object@pta$vnames$th[[b]]
        }
        if (add.class) {
          class(return.value[[b]]$th) <- c("lavaan.vector", "numeric")
        }
      }
      # !conditional.x
    } else {
      # if conditional.x = TRUE
      # residual covariance matrix
      return.value[[b]]$res.cov  <- lavimplied$res.cov[[b]]
      if (add.labels) {
        rownames(return.value[[b]]$res.cov) <-
          colnames(return.value[[b]]$res.cov) <-
          ov.names.res[[b]]
      }
      if (add.class) {
        class(return.value[[b]]$res.cov) <-
          c("lavaan.matrix.symmetric", "matrix")
      }

      # intercepts
      if (lavmodel@meanstructure) {
        return.value[[b]]$res.int <- as.numeric(lavimplied$res.int[[b]])
        if (add.labels) {
          names(return.value[[b]]$res.int) <- ov.names.res[[b]]
        }
        if (add.class) {
          class(return.value[[b]]$res.int) <- c("lavaan.vector", "numeric")
        }
      }

      # thresholds
      if (lavmodel@categorical) {
        return.value[[b]]$res.th <- as.numeric(lavimplied$res.th[[b]])
        if (length(object@Model@num.idx[[b]]) > 0L) {
          num.idx <- which(object@Model@th.idx[[b]] == 0)
          return.value[[b]]$res.th <- return.value[[b]]$res.th[-num.idx]
        }
        if (add.labels) {
          names(return.value[[b]]$res.th) <- object@pta$vnames$th[[b]]
        }
        if (add.class) {
          class(return.value[[b]]$res.th) <- c("lavaan.vector", "numeric")
        }
      }

      # slopes
      if (lavmodel@nexo[b] > 0L) {
        return.value[[b]]$res.slopes  <- lavimplied$res.slopes[[b]]
        if (add.labels) {
          rownames(return.value[[b]]$res.slopes) <- ov.names.res[[b]]
          colnames(return.value[[b]]$res.slopes) <- ov.names.x[[b]]
        }
        if (add.class) {
          class(return.value[[b]]$res.slopes) <- c("lavaan.matrix", "matrix")
        }
      }

      # cov.x
      if (lavmodel@nexo[b] > 0L) {
        return.value[[b]]$cov.x  <- lavimplied$cov.x[[b]]
        if (add.labels) {
          rownames(return.value[[b]]$cov.x) <- ov.names.x[[b]]
          colnames(return.value[[b]]$cov.x) <- ov.names.x[[b]]
        }
        if (add.class) {
          class(return.value[[b]]$cov.x) <-
            c("lavaan.matrix.symmetric", "matrix")
        }
      }

      # mean.x
      if (lavmodel@nexo[b] > 0L) {
        return.value[[b]]$mean.x  <- as.numeric(lavimplied$mean.x[[b]])
        if (add.labels) {
          names(return.value[[b]]$mean.x) <- ov.names.x[[b]]
        }
        if (add.class) {
          class(return.value[[b]]$mean.x) <- c("lavaan.vector", "numeric")
        }
      }


    } # conditional.x

    # stochastic weights
    if (lavmodel@group.w.free) {
      return.value[[b]]$group.w <- lavimplied$group.w[[b]]
      if (add.labels) {
        names(return.value[[b]]$group.w) <- "w" # somewhat redundant
      }
      if (add.class) {
        class(return.value[[b]]$group.w) <- c("lavaan.vector", "numeric")
      }
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (nblocks > 1L) {
    names(return.value) <- object@Data@block.label
  }

  return.value
}


# residuals: _inspect_sampstat - _inspect_implied
lav_object_inspect_residuals <- function(object, h1 = TRUE,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  lav_residuals(object, type = "raw", h1 = h1,
    add.labels = add.labels, add.class = add.class,
    drop.list.single.group = drop.list.single.group)
}


lav_object_inspect_cov_lv <- function(object, correlation.metric = FALSE,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
  # compute lv covar
  return.value <- lav_model_veta(lavmodel = object@Model, remove.dummy.lv = TRUE)

  # nblocks
  nblocks <- length(return.value)

  # cor + labels + class
  for (b in seq_len(nblocks)) {

    if (correlation.metric && nrow(return.value[[b]]) > 1L) {
      # note: cov2cor fails if matrix is empty!
      return.value[[b]] <- cov2cor(return.value[[b]])
    }

    if (add.labels) {
      colnames(return.value[[b]]) <- rownames(return.value[[b]]) <-
        object@pta$vnames$lv[[b]]
    }

    if (add.class) {
      class(return.value[[b]]) <- c("lavaan.matrix.symmetric", "matrix")
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (nblocks > 1L) {
    names(return.value) <- object@Data@block.label
  }

  return.value
}

lav_object_inspect_mean_lv <- function(object,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
  # compute lv means
  return.value <- lav_model_eeta(lavmodel       = object@Model,
    lavsamplestats = object@SampleStats,
    remove.dummy.lv = TRUE)

  # nblocks
  nblocks <- length(return.value)

  # ensure numeric
  return.value <- lapply(return.value, as.numeric)

  # labels + class
  for (b in seq_len(nblocks)) {
    if (add.labels && length(return.value[[b]]) > 0L) {
      names(return.value[[b]]) <- object@pta$vnames$lv[[b]]
    }
    if (add.class) {
      class(return.value[[b]]) <- c("lavaan.vector", "numeric")
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (nblocks > 1L) {
    names(return.value) <- object@Data@block.label
  }

  return.value
}

lav_object_inspect_cov_all <- function(object, correlation.metric = FALSE,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
  # compute extended model implied covariance matrix (both ov and lv)
  return.value <- lav_model_cov_both(lavmodel = object@Model,
    remove.dummy.lv = TRUE)

  # nblocks
  nblocks <- length(return.value)

  # cor + labels + class
  for (b in seq_len(nblocks)) {

    if (correlation.metric && nrow(return.value[[b]]) > 1L) {
      # note: cov2cor fails if matrix is empty!
      return.value[[b]] <- cov2cor(return.value[[b]])
    }

    if (add.labels) {
      tmp.names <- c(object@pta$vnames$ov.model[[b]],
        object@pta$vnames$lv[[b]])
      colnames(return.value[[b]]) <- rownames(return.value[[b]]) <- tmp.names
    }
    if (add.class) {
      class(return.value[[b]]) <- c("lavaan.matrix.symmetric", "matrix")
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (nblocks > 1L) {
    names(return.value) <- object@Data@block.label
  }

  return.value
}


lav_object_inspect_cov_ov <- function(object, correlation.metric = FALSE,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
  # get model-implied covariance matrix observed
  if (object@Model@conditional.x) {
    return.value <- object@implied$res.cov
  } else {
    return.value <- object@implied$cov
  }

  # nblocks
  nblocks <- length(return.value)

  # cor + labels + class
  for (b in seq_len(nblocks)) {

    if (correlation.metric && nrow(return.value[[b]]) > 1L) {
      # note: cov2cor fails if matrix is empty!
      return.value[[b]] <- cov2cor(return.value[[b]])
    }

    if (add.labels) {
      colnames(return.value[[b]]) <- rownames(return.value[[b]]) <-
        object@pta$vnames$ov.model[[b]]
    }
    if (add.class) {
      class(return.value[[b]]) <- c("lavaan.matrix.symmetric", "matrix")
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else {
    names(return.value) <- object@Data@block.label
  }

  return.value
}

lav_object_inspect_mean_ov <- function(object,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
  # compute ov means
  if (object@Model@conditional.x) {
    return.value <- object@implied$res.int
  } else {
    return.value <- object@implied$mean
  }

  # nblocks
  nblocks <- length(return.value)

  # make numeric
  return.value <- lapply(return.value, as.numeric)

  # labels + class
  for (b in seq_len(nblocks)) {
    if (add.labels && length(return.value[[b]]) > 0L) {
      names(return.value[[b]]) <- object@pta$vnames$ov.model[[b]]
    }
    if (add.class) {
      class(return.value[[b]]) <- c("lavaan.vector", "numeric")
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (nblocks > 1L) {
    names(return.value) <- object@Data@block.label
  }

  return.value
}

lav_object_inspect_th <- function(object,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
  # thresholds
  if (object@Model@conditional.x) {
    return.value <- object@implied$res.th
  } else {
    return.value <- object@implied$th
  }

  # nblocks
  nblocks <- length(return.value)

  # make numeric
  return.value <- lapply(return.value, as.numeric)

  # labels + class
  for (b in seq_len(nblocks)) {
    if (length(object@Model@num.idx[[b]]) > 0L) {
      num.idx <- which(object@Model@th.idx[[b]] == 0)
      return.value[[b]] <- return.value[[b]][-num.idx]
    }
    if (add.labels && length(return.value[[b]]) > 0L) {
      names(return.value[[b]]) <- object@pta$vnames$th[[b]]
    }
    if (add.class) {
      class(return.value[[b]]) <- c("lavaan.vector", "numeric")
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (nblocks > 1L) {
    names(return.value) <- object@Data@block.label
  }

  return.value
}

lav_object_inspect_th_idx <- function(object,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
  # thresholds idx
  return.value <- object@SampleStats@th.idx

  # nblocks
  nblocks <- length(return.value)

  # labels + class
  for (b in seq_len(nblocks)) {
    if (add.labels && length(return.value[[b]]) > 0L) {
      names(return.value[[b]]) <- object@SampleStats@th.names[[b]]
    }
    if (add.class && !is.null(return.value[[b]])) {
      class(return.value[[b]]) <- c("lavaan.vector", "numeric")
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (nblocks > 1L) {
    names(return.value) <- object@Data@block.label
  }

  return.value
}

lav_object_inspect_vy <- function(object,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
  # 'unconditional' model-implied variances
  #  - same as diag(Sigma.hat) if all Y are continuous)
  #  - 1.0 (or delta^2) if categorical
  #  - if also Gamma, cov.x is used (only if categorical)

  return.value <- lav_model_vy(lavmodel = object@Model, GLIST = NULL,
    diagonal.only = TRUE)

  # nblocks
  nblocks <- length(return.value)

  # labels + class
  for (b in seq_len(nblocks)) {
    if (add.labels && length(return.value[[b]]) > 0L) {
      if (object@Model@categorical) {
        names(return.value[[b]]) <- object@pta$vnames$ov.nox[[b]]
      } else {
        names(return.value[[b]]) <- object@pta$vnames$ov[[b]]
      }
    }
    if (add.class) {
      class(return.value[[b]]) <- c("lavaan.vector", "numeric")
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (nblocks > 1L) {
    names(return.value) <- object@Data@block.label
  }

  return.value
}

lav_object_inspect_fs_determinacy <- function(object,
  squared = TRUE, fs.method = "regression",
  add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  FS <- lavPredict(object, type = "lv", method = fs.method, rel = TRUE)
  return.value <- attr(FS, "rel")

  # determinacies or reliabilities?
  if (!squared) {
    return.value <- lapply(return.value, sqrt)
  }

  # nblocks
  nblocks <- length(return.value)

  # ensure numeric
  return.value <- lapply(return.value, as.numeric)

  # labels + class
  for (b in seq_len(nblocks)) {
    if (add.labels && length(return.value[[b]]) > 0L) {
      names(return.value[[b]]) <- object@pta$vnames$lv[[b]]
    }
    if (add.class) {
      class(return.value[[b]]) <- c("lavaan.vector", "numeric")
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (nblocks > 1L) {
    names(return.value) <- object@Data@block.label
  }

  return.value
}


lav_object_inspect_theta <- function(object, correlation.metric = FALSE,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
  # get residual covariances
  return.value <- lav_model_theta(lavmodel = object@Model)

  # nblocks
  nblocks <- length(return.value)

  # labels + class
  for (b in seq_len(nblocks)) {

    if (correlation.metric && nrow(return.value[[b]]) > 0L) {
      if (all(return.value[[b]] == 0)) {
        return.value[[b]] <- return.value[[b]]
      } else {
        return.value[[b]] <- cov2cor(return.value[[b]])
      }
    }

    if (add.labels && length(return.value[[b]]) > 0L) {
      colnames(return.value[[b]]) <- rownames(return.value[[b]]) <-
        object@pta$vnames$ov.model[[b]]
    }

    if (add.class) {
      class(return.value[[b]]) <- c("lavaan.matrix.symmetric", "matrix")
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (nblocks > 1L) {
    names(return.value) <- object@Data@block.label
  }

  return.value
}


lav_object_inspect_missing_coverage <- function(object,          # nolint
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  n.g <- object@Data@ngroups
  return.value <- vector("list", n.g)

  for (g in 1:n.g) {
    if (!is.null(object@Data@Mp[[g]])) {
      return.value[[g]] <- object@Data@Mp[[g]]$coverage
    } else {
      nvar <- length(object@Data@ov.names[[g]])
      return.value[[g]] <- matrix(1.0, nvar, nvar)
    }

    if (add.labels && length(return.value[[g]]) > 0L) {
      colnames(return.value[[g]]) <- rownames(return.value[[g]]) <-
        object@pta$vnames$ov.model[[g]]
    }

    if (add.class) {
      class(return.value[[g]]) <- c("lavaan.matrix.symmetric", "matrix")
    }
  }

  if (n.g == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else {
    if (length(object@Data@group.label) > 0L) {
      names(return.value) <- unlist(object@Data@group.label)
    }
  }

  return.value
}

lav_object_inspect_missing_patterns <- function(object,           # nolint
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  n.g <- object@Data@ngroups
  return.value <- vector("list", n.g)

  for (g in 1:n.g) {
    if (!is.null(object@Data@Mp[[g]])) {
      return.value[[g]] <- object@Data@Mp[[g]]$pat
    } else {
      nvar <- length(object@Data@ov.names[[g]])
      return.value[[g]] <- matrix(TRUE, 1L, nvar)
      rownames(return.value[[g]]) <- object@Data@nobs[[g]]
    }

    if (add.labels && length(return.value[[g]]) > 0L) {
      colnames(return.value[[g]]) <- object@pta$vnames$ov.model[[g]]
    }

    if (add.class) {
      class(return.value[[g]]) <- c("lavaan.matrix", "matrix")
    }
  }

  if (n.g == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else {
    if (length(object@Data@group.label) > 0L) {
      names(return.value) <- unlist(object@Data@group.label)
    }
  }

  return.value
}

lav_object_inspect_empty_idx <- function(object,
                                         drop.list.single.group = FALSE) {

  n.g <- object@Data@ngroups

  # get empty idx
  return.value <- vector("list", n.g)

  for (g in 1:n.g) {
    if (!is.null(object@Data@Mp[[g]])) {
      return.value[[g]] <- object@Data@Mp[[g]]$empty.idx
    } else {
      return.value[[g]] <- integer(0L)
    }
  }

  if (n.g == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else {
    if (length(object@Data@group.label) > 0L) {
      names(return.value) <- unlist(object@Data@group.label)
    }
  }

  return.value
}


lav_object_inspect_wls_est <- function(object,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  return.value <- lav_model_wls_est(object@Model)

  if (add.labels) {
    tmp.names <- lav_object_inspect_delta_rownames(object,
      drop.list.single.group = FALSE)
  }

  # nblocks
  nblocks <- length(return.value)

  for (b in seq_len(nblocks)) {
    if (add.labels && length(return.value[[b]]) > 0L &&
        object@Data@nlevels == 1L) {
      names(return.value[[b]]) <- tmp.names[[b]]
    }

    if (add.class) {
      class(return.value[[b]]) <- c("lavaan.vector", "numeric")
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (nblocks > 1L) {
    names(return.value) <- object@Data@block.label
  }

  return.value
}

lav_object_inspect_wls_obs <- function(object,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  return.value <- object@SampleStats@WLS.obs ### FIXME: should be in @h1??

  if (add.labels) {
    tmp.names <- lav_object_inspect_delta_rownames(object,
      drop.list.single.group = FALSE)
  }

  # nblocks
  nblocks <- length(return.value)

  for (b in seq_len(nblocks)) {
    if (add.labels && length(return.value[[b]]) > 0L &&
        object@Data@nlevels == 1L) {
      names(return.value[[b]]) <- tmp.names[[b]]
    }

    if (add.class) {
      class(return.value[[b]]) <- c("lavaan.vector", "numeric")
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (nblocks > 1L) {
    names(return.value) <- object@Data@block.label
  }

  return.value
}

lav_object_inspect_wls_v <- function(object,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  # return.value <- lav_model_wls_v(lavmodel       = object@Model,
  #                       lavsamplestats = object@SampleStats,
  #                       structured     = TRUE,
  #                       lavdata        = object@Data)
  # WLS.V == (traditionally) h1 expected information
  return.value <- lav_model_h1_information_expected(lavobject = object)
  # this affects fit measures gfi, agfi, pgfi


  # nblocks
  nblocks <- length(return.value)

  # if estimator == "DWLS" or "ULS", we only stored the diagonal
  # hence, we create a full matrix here
  if (object@Options$estimator %in% c("DWLS", "ULS")) {
    return.value <- lapply(return.value,
      function(x) {
        nr <- NROW(x)
        diag(x, nrow = nr, ncol = nr)
      })
  }

  if (add.labels) {
    tmp.names <- lav_object_inspect_delta_rownames(object,
      drop.list.single.group = FALSE)
  }

  # label + class
  for (b in seq_len(nblocks)) {
    # labels
    if (add.labels && nrow(return.value[[b]]) > 0L &&
        object@Data@nlevels == 1L) {
      colnames(return.value[[b]]) <-
        rownames(return.value[[b]]) <- tmp.names[[b]]
    }

    # class
    if (add.class) {
      class(return.value[[b]]) <- c("lavaan.matrix", "matrix")
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (nblocks > 1L) {
    names(return.value) <- object@Data@block.label
  }

  return.value
}


lav_object_inspect_sampstat_gamma <- function(object,         # nolint
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  if (!is.null(object@SampleStats@NACOV[[1]])) {
    return.value <- object@SampleStats@NACOV
  } else {
    return.value <- lav_object_gamma(object)
  }

  if (add.labels) {
    tmp.names <- lav_object_inspect_delta_rownames(object,
      drop.list.single.group = FALSE)
  }

  # nblocks
  nblocks <- length(return.value)

  if (nblocks == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]

    # labels
    if (add.labels) {
      colnames(return.value) <- rownames(return.value) <- tmp.names[[1]]
    }

    # class
    if (add.class) {
      class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
    }
  } else {
    if (object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) {
      names(return.value) <- unlist(object@Data@group.label)

      # labels
      if (add.labels) {
        for (g in seq_len(object@Data@ngroups)) {
          colnames(return.value[[g]]) <-
            rownames(return.value[[g]]) <- tmp.names[[g]]
        }
      }

      # class
      if (add.class) {
        for (g in seq_len(object@Data@ngroups)) {
          class(return.value[[g]]) <- c("lavaan.matrix.symmetric", "matrix")
        }
      }
    } else if (object@Data@nlevels > 1L &&
      length(object@Data@group.label) == 0L) {
      names(return.value) <- object@Data@level.label
    }
  }

  return.value
}


lav_object_inspect_gradient <- function(object,
    add.labels = FALSE, add.class = FALSE, logl = FALSE,
    optim = FALSE) {

  lavmodel       <- object@Model
  lavdata        <- object@Data
  lavsamplestats <- object@SampleStats

  if (optim) {
    logl <- FALSE
  }

  if (lavsamplestats@missing.flag ||
    object@Options$estimator == "PML") {
    group.weight <- FALSE
  } else {
    group.weight <- TRUE
  }
  current.verbose <- lav_verbose()
  if (lav_verbose(FALSE)) on.exit(lav_verbose(current.verbose), TRUE)
  dx <- lav_model_gradient(lavmodel       = lavmodel,
    GLIST          = NULL,
    lavsamplestats = lavsamplestats,
    lavdata        = object@Data,
    lavcache       = object@Cache,
    type           = "free",
    group.weight   = group.weight)
  lav_verbose(current.verbose)
  # if logl, rescale to get gradient wrt the loglikelihood
  if (logl) {
    if (lavmodel@estimator %in% c("ML")) {
      if (lavdata@nlevels == 1L) {
        # currently, this is just a sign switch
        dx <- -1 * dx
      } else {
        lavpartable <- object@ParTable
        # gradient.log = gradient.obj * (2 * tmp.n) / nclusters

        if (lavdata@ngroups == 1L) {
          tmp.n <- lavdata@Lp[[1]]$nclusters[[1]]
          nclusters <- lavdata@Lp[[1]]$nclusters[[2]]
          dx <- dx * (2 * tmp.n) / nclusters
        } else {
          group.values <- lav_partable_group_values(lavpartable)
          for (g in seq_len(lavdata@ngroups)) {
            tmp.n <- lavdata@Lp[[g]]$nclusters[[1]]
            nclusters <- lavdata@Lp[[g]]$nclusters[[2]]
            g.idx <-
              which((lavpartable$group ==
                group.values[g])[lavpartable$free > 0L])
            dx[g.idx] <- dx[g.idx] * (2 * tmp.n) / nclusters
          }
        }
      }
    } else {
      # FIXME:
      # non-likelihood: what to do? just switch the sign for now.
      # Note: this is used in lavTestScore()
      dx <- -1 * dx
    }
  }

  # optim?
  if (optim) {
    # 1. scale (note: divide, not multiply!)
    if (!is.null(object@optim$parscale)) {
      dx <- dx / object@optim$parscale
    }

    # 2. pack
    if (lavmodel@eq.constraints) {
      dx <- as.numeric(dx %*% lavmodel@eq.constraints.K)
    }
    # only for PML: divide by tmp.n (to speed up convergence)
    if (lavmodel@estimator == "PML") {
      dx <- dx / lavsamplestats@ntotal
    }
  }

  # labels
  if (add.labels) {
    if (optim && lavmodel@eq.constraints) {
      tmp.names.all <- lav_partable_labels(object@ParTable, type = "free")
      tmp.seq <- seq_len(length(tmp.names.all))
      pack.seq <- as.numeric((tmp.seq - lavmodel@eq.constraints.k0) %*%
        +lavmodel@eq.constraints.K)
      ok.idx <- which(pack.seq %in% tmp.seq)
      tmp.names <- rep("(eq.con)", length(pack.seq))
      tmp.names[ok.idx] <- tmp.names.all[pack.seq[ok.idx]]
      names(dx) <- tmp.names
    } else {
      names(dx) <- lav_partable_labels(object@ParTable, type = "free")
    }
  }

  # class
  if (add.class) {
    class(dx) <- c("lavaan.vector", "numeric")
  }

  dx
}

lav_object_inspect_hessian <- function(object,
    add.labels = FALSE, add.class = FALSE) {

  return.value <- lav_model_hessian(lavmodel       = object@Model,
    lavsamplestats = object@SampleStats,
    lavdata        = object@Data,
    lavcache       = object@Cache,
    lavoptions     = object@Options,
    group.weight   = TRUE)

  # labels
  if (add.labels) {
    colnames(return.value) <- rownames(return.value) <-
      lav_partable_labels(object@ParTable, type = "free")
  }

  # class
  if (add.class) {
    class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
  }

  return.value
}

lav_object_inspect_information <- function(object,
    information = "default", augmented = FALSE, inverted = FALSE,
    add.labels = FALSE, add.class = FALSE) {

  if (information != "default") {
    # override option
    object@Options$information <- information
  }

  return.value <- lav_model_information(lavmodel =  object@Model,
    lavsamplestats = object@SampleStats,
    lavdata        = object@Data,
    lavcache       = object@Cache,
    lavimplied     = object@implied,
    lavh1          = object@h1,
    lavoptions     = object@Options,
    extra          = FALSE,
    augmented      = augmented,
    inverted       = inverted)

  # labels
  if (add.labels) {
    tmp.names <- lav_partable_labels(object@ParTable, type = "free")
    if (augmented) {
      n.extra <- nrow(return.value) - length(tmp.names)
      if (n.extra > 0L) {
        tmp.names <- c(tmp.names, paste("aug", 1:n.extra, sep = ""))
      }
    }
    colnames(return.value) <- rownames(return.value) <- tmp.names
  }

  # class
  if (add.class) {
    class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
  }

  return.value
}

lav_object_inspect_h1_information <- function(object,            # nolint
    information = "default", h1.information = "default", inverted = FALSE,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  if (information != "default") {
    # override option
    object@Options$information <- information
  }
  if (h1.information != "default") {
    # override option
    object@Options$h1.information <- h1.information
  }

  lavmodel <- object@Model
  lavdata  <- object@Data

  # list!
  return.value <- lav_model_h1_information(lavmodel = lavmodel,
    lavsamplestats = object@SampleStats,
    lavdata        = lavdata,
    lavcache       = object@Cache,
    lavimplied     = object@implied,
    lavh1          = object@h1,
    lavoptions     = object@Options)

  # inverted? (NOT USED)
  # if(inverted) {
  #    return.value <- lapply(return.value, solve) # FIXME: handle errors...
  # }

  if (add.labels) {
    tmp.names <- lav_object_inspect_delta_rownames(object,
      drop.list.single.group = FALSE)
  }

  # labels/class per group
  for (g in seq_len(lavmodel@ngroups)) {
    # labels
    if (add.labels) {
      colnames(return.value[[g]]) <-
        rownames(return.value[[g]]) <- tmp.names[[g]]
    }

    # class
    if (add.class) {
      class(return.value[[g]]) <- c("lavaan.matrix.symmetric", "matrix")
    }
  }

  # drop list?
  if (lavmodel@ngroups == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (!is.null(lavdata)) {
    if (length(lavdata@group.label) > 0L) {
      names(return.value) <- unlist(lavdata@group.label)
    }
  }

  return.value
}

# only to provide a direct function to the old 'getVariability()' function
lav_object_inspect_firstorder <- function(object,
    add.labels = FALSE, add.class = FALSE) {

  tmp.b0 <- lav_model_information_firstorder(lavmodel =  object@Model,
    lavsamplestats = object@SampleStats,
    lavdata        = object@Data,
    lavcache       = object@Cache,
    lavoptions     = object@Options,
    check.pd       = FALSE,
    augmented      = FALSE,
    inverted       = FALSE)
  attr(tmp.b0, "B0.group") <- NULL
  return.value <- tmp.b0

  # labels
  if (add.labels) {
    colnames(return.value) <- rownames(return.value) <-
      lav_partable_labels(object@ParTable, type = "free")
  }

  # class
  if (add.class) {
    class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
  }

  return.value
}

lav_object_inspect_vcov <- function(object, standardized = FALSE,
    type = "std.all", free.only = TRUE,
    add.labels = FALSE, add.class = FALSE, remove.duplicated = FALSE) {

  lavmodel <- object@Model
  lavoptions <- object@Options

  # store partable with pta in object to use cache in called functions
  if (is.null(attr(object, "vnames"))) {
    object@ParTable <- lav_partable_set_cache(object@ParTable, object@pta)
  }

  if (object@optim$npar == 0) {
    return.value <- matrix(0, 0, 0)
  } else {
    # check if we already have it
    # tmp <- try(slot(object, "vcov"), silent = TRUE)
    # if( !inherits(tmp, "try-error") && !is.null(object@vcov$vcov)
    #   && !(rotation && standardized)) {
    if (!is.null(object@vcov$vcov)) {
      return.value <- object@vcov$vcov # if this changes, tag @TDJorgensen in commit message
    } else {
      # compute it again
      # if(rotation && standardized) {
      #    lavmodel <- lav_model_set_parameters(lavmodel,
      #                    x = object@optim$x)
      #    lavoptions <- object@Options
      #    lavoptions$rotation.se <- "delta"
      # }
      return.value <- lav_model_vcov(lavmodel       = lavmodel,
        lavsamplestats = object@SampleStats,
        lavoptions     = lavoptions,
        lavdata        = object@Data,
        lavcache       = object@Cache,
        lavimplied     = object@implied,
        lavh1          = object@h1
      )
      # if(rotation && !standardized) {
      #    # fixme: compute tmp.vcov.rot manually...
      #    stop("lavaan ERROR: rerun with store.vcov = TRUE")
      # }

      if (is.null(return.value)) {
        return(return.value)
      }
    }
  }

  # strip attributes
  attr(return.value, "E.inv") <- NULL
  attr(return.value, "B0") <- NULL
  attr(return.value, "B0.group") <- NULL
  attr(return.value, "Delta") <- NULL
  attr(return.value, "WLS.V") <- NULL
  attr(return.value, "tmp.boot.COEF") <- NULL
  attr(return.value, "tmp.boot.TEST") <- NULL

  # standardized?
  if (standardized) {
    if (type == "std.lv") {
      tmp.fun <- lav_standardize_lv_x
    } else if (type == "std.all") {
      tmp.fun <- lav_standardize_all_x
    } else if (type == "std.nox") {
      tmp.fun <- lav_standardize_all_nox_x
    }

    x.vec <- lav_model_get_parameters(lavmodel)
    tmp.jac <- try(lav_func_jacobian_complex(func = tmp.fun, x = x.vec,
      lavobject = object),
    silent = TRUE)
    if (inherits(tmp.jac, "try-error")) { # eg. pnorm()
      tmp.jac <- lav_func_jacobian_simple(func = tmp.fun, x = x.vec,
        lavobject = object)
    }
    # }

    # tmp.jac contains *all* parameters in the parameter table
    if (free.only) {
      if (object@Model@ceq.simple.only) {
        free.idx <- which(object@ParTable$free > 0L &
          !duplicated(object@ParTable$free))
      } else {
        free.idx <- which(object@ParTable$free > 0L)
      }
      tmp.jac <- tmp.jac[free.idx, , drop = FALSE]
    }

    return.value <- tmp.jac %*% return.value %*% t(tmp.jac)

    # force return.value to be symmetric and pd
    return.value <- (return.value + t(return.value)) / 2
    # return.value <- lav_matrix_symmetric_force_pd(return.value,
    #                                     tol = 1e-09) # was 1e-06 < 0.6-9
  }

  # labels
  if (add.labels) {
    # if(rotation && !free.only) {
    #    # todo
    # } else {
    colnames(return.value) <- rownames(return.value) <-
      lav_partable_labels(object@ParTable,
                          ## add "user" labels?
                          type = ifelse(standardized && !free.only,
                                        "user", "free"))
    # }
  }

  # alias?
  if (remove.duplicated && lavmodel@eq.constraints) {
    simple.flag <- lav_constraints_check_simple(lavmodel)
    if (simple.flag) {
      tmp.lab <- lav_partable_labels(object@ParTable, type = "free")
      dup.flag <- duplicated(tmp.lab)
      return.value <- return.value[!dup.flag, !dup.flag, drop = FALSE]
    } else {
      lav_msg_warn(
        gettext("alias is TRUE, but equality constraints do not appear
                to be simple; returning full vcov"))
    }
  }

  # class
  if (add.class) {
    class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
  }

  return.value
}

lav_object_inspect_vcov_def <- function(object, joint = FALSE,
    standardized = FALSE, type = "std.all",
    add.labels = FALSE, add.class = FALSE) {

  lavmodel    <- object@Model
  lavpartable <- object@ParTable
  free.idx <- which(lavpartable$free > 0L)
  def.idx <- which(lavpartable$op == ":=")
  joint.idx <- c(free.idx, def.idx)

  if (!joint && length(def.idx) == 0L) {
    return(matrix(0, 0, 0))
  } else if (joint && length(joint.idx) == 0L) {
    return(matrix(0, 0, 0))
  }

  if (standardized) {
    # compute tmp.vcov for "free" parameters only
    tmp.vcov <- lav_object_inspect_vcov(object,
      standardized = TRUE,
      type = type, free.only = FALSE,
      add.labels = FALSE, add.class = FALSE)
    if (joint) {
      return.value <- tmp.vcov[joint.idx, joint.idx, drop = FALSE]
    } else {
      return.value <- tmp.vcov[def.idx, def.idx, drop = FALSE]
    }
  } else {
    # get free parameters
    x <- lav_model_get_parameters(lavmodel, type = "free")

    # bootstrap or not?
    if (!is.null(object@boot$coef)) {
      tmp.boot <- object@boot$coef
      # remove NA rows
      error.idx <- attr(tmp.boot, "error.idx")
      if (length(error.idx) > 0L) {
        tmp.boot <- tmp.boot[-error.idx, , drop = FALSE] # drops attributes
      }
      tmp.boot.def <- apply(tmp.boot, 1L, lavmodel@def.function)
      if (length(def.idx) == 1L) {
        tmp.boot.def <- as.matrix(tmp.boot.def)
      } else {
        tmp.boot.def <- t(tmp.boot.def)
      }
      return.value <- cov(tmp.boot.def)
    } else {
      # tmp.vcov
      tmp.vcov <- lav_object_inspect_vcov(object,
        standardized = FALSE,
        type = type, free.only = TRUE,
        add.labels = FALSE,
        add.class = FALSE)

      # regular delta method
      tmp.jac <- try(lav_func_jacobian_complex(func = lavmodel@def.function,
        x = x), silent = TRUE)
      if (inherits(tmp.jac, "try-error")) { # eg. pnorm()
        tmp.jac <- lav_func_jacobian_simple(func = lavmodel@def.function,
          x = x)
      }
      if (joint) {
        tmp.jac2 <- rbind(diag(nrow = ncol(tmp.jac)), tmp.jac)
        return.value <- tmp.jac2 %*% tmp.vcov %*% t(tmp.jac2)
      } else {
        return.value <- tmp.jac %*% tmp.vcov %*% t(tmp.jac)
      }
    }
  }

  # labels
  if (add.labels) {
    if (joint) {
      lhs.names <- lavpartable$lhs[joint.idx]
    } else {
      lhs.names <- lavpartable$lhs[def.idx]
    }
    colnames(return.value) <- rownames(return.value) <- lhs.names
  }

  # class
  if (add.class) {
    class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
  }

  return.value
}

lav_object_inspect_UGamma <- function(object,                  # nolint
    add.labels = FALSE, add.class = FALSE) {

  out <- lav_test_satorra_bentler(lavobject     = object,
    method        = "original",
    return.ugamma = TRUE)
  return.value <- out$UGamma

  # labels
  # if(add.labels) {
  # colnames(return.value) <- rownames(return.value) <-
  # }

  # class
  if (add.class) {
    class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
  }

  return.value
}

lav_object_inspect_UfromUGamma <- function(object,            # nolint
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  out <- lav_test_satorra_bentler(lavobject     = object,
    method        = "original",
    return.u      = TRUE)
  return.value <- out$UfromUGamma

  # labels
  # if(add.labels) {
  # colnames(return.value) <- rownames(return.value) <-
  # }

  # class
  if (add.class) {
    class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
  }

  return.value
}


# Delta (jacobian: d samplestats / d free_parameters)
lav_object_inspect_delta <- function(object,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  lavmodel    <- object@Model
  lavdata     <- object@Data
  lavpartable <- object@ParTable
  lavpta      <- object@pta

  return.value <- lav_object_inspect_delta_internal(lavmodel = lavmodel,
    lavdata = lavdata, lavpartable = lavpartable,
    add.labels = add.labels, add.class = add.class,
    drop.list.single.group = drop.list.single.group)

  return.value
}

lav_object_inspect_delta_rownames <- function(                # nolint
    object,
    lavmodel = NULL,
    lavpartable = NULL,
    drop.list.single.group = FALSE) {
  if (!is.null(object)) {
    lavmodel    <- object@Model
    lavpartable <- object@ParTable
    lavpta      <- object@pta
    lavdata     <- object@Data
  } else {
    lavdata     <- NULL
    lavpta <- lav_partable_attributes(lavpartable)
  }

  categorical    <- lavmodel@categorical
  correlation    <- lavmodel@correlation
  conditional.x  <- lavmodel@conditional.x
  group.w.free   <- lavmodel@group.w.free
  nvar           <- lavmodel@nvar
  num.idx        <- lavmodel@num.idx
  th.idx         <- lavmodel@th.idx
  nblocks        <- lavmodel@nblocks

  # store names per block, rbind later
  tmp.names <- vector("list", length = nblocks)

  # output is per group
  return.value <- vector("list", lavmodel@ngroups)

  for (g in 1:nblocks) {

    if (conditional.x) {
      ov.names <- lavpta$vnames$ov.nox[[g]]
    } else {
      ov.names <- lavpta$vnames$ov[[g]]
    }
    ov.names.x <- lavpta$vnames$ov.x[[g]]
    nvar <- length(ov.names)


    names.cov <- names.cor <- names.var <- character(0L)
    names.mu <- names.pi <- names.th <- character(0L)
    names.gw <- character(0L)

    # Sigma
    # - if continuous: vech(Sigma)
    # - if categorical: first numeric variances, then
    # tmp <- apply(expand.grid(ov.names, ov.names), 1L,
    #             paste, collapse = "~~")

    # if(categorical) {
    #    names.cor <- tmp[lav_matrix_vech_idx(nvar, diagonal = FALSE)]
    #    names.var <- tmp[lav_matrix_diag_idx(nvar)[num.idx[[g]]]]
    # } else {
    #    names.cov <- tmp[lav_matrix_vech_idx(nvar, diagonal = TRUE)]
    # }

    # NOTE: in 0.6-1, we use the same order, but 'label' in row-wise
    # format (eg x1 ~~ x2 instead of x2 ~~ x1)
    tmp <- matrix(apply(expand.grid(ov.names, ov.names), 1L,
      paste, collapse = "~~"), nrow = nvar)
    if (categorical) {
      names.cor <- lav_matrix_vechru(tmp, diagonal = FALSE)
      names.var <- diag(tmp)[num.idx[[g]]]
    } else if (correlation) {
      names.cor <- lav_matrix_vechru(tmp, diagonal = FALSE)
    } else {
      names.cov <- lav_matrix_vechru(tmp, diagonal = TRUE)
    }


    # Mu
    if (!categorical && lavmodel@meanstructure) {
      names.mu <- paste(ov.names, "~1", sep = "")
    }

    # Pi
    if (conditional.x && lavmodel@nexo[g] > 0L) {
      names.pi <- apply(expand.grid(ov.names, ov.names.x), 1L,
        paste, collapse = "~")
    }

    # th
    if (categorical) {
      names.th <- lavpta$vnames$th[[g]]
      # interweave numeric intercepts, if any
      if (length(num.idx[[g]]) > 0L) {
        tmp <- character(length(th.idx[[g]]))
        tmp[th.idx[[g]] > 0] <- names.th
        tmp[th.idx[[g]] == 0] <- paste(ov.names[num.idx[[g]]],
          "~1", sep = "")
        names.th <- tmp
      }
    }

    # gw
    if (group.w.free) {
      names.gw <- "w"
    }

    tmp.names[[g]] <- c(names.gw,
      names.th, names.mu,
      names.pi,
      names.cov, names.var, names.cor)

  } # blocks

  # multilevel?
  if (lavmodel@multilevel) {
    for (g in 1:lavmodel@ngroups) {
      return.value[[g]] <- c(tmp.names[[(g - 1) * 2 + 1]],
        tmp.names[[(g - 1) * 2 + 2]])
    }
  } else {
    return.value <- tmp.names
  }

  # drop list?
  if (lavmodel@ngroups == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (!is.null(lavdata)) {
    if (length(lavdata@group.label) > 0L) {
      names(return.value) <- unlist(lavdata@group.label)
    }
  }

  return.value
}

lav_object_inspect_delta_internal <- function(                   # nolint
    lavmodel = NULL, lavdata  = NULL,
    lavpartable = NULL,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  return.value <- lav_model_delta(lavmodel)

  if (add.labels) {
    tmp.pnames <- lav_partable_labels(lavpartable, type = "free")
    tmp.rownames  <- lav_object_inspect_delta_rownames(object = NULL,
      lavmodel = lavmodel, lavpartable = lavpartable,
      drop.list.single.group = FALSE)
  }

  for (g in seq_len(lavmodel@ngroups)) {
    # add labels
    if (add.labels) {
      colnames(return.value[[g]]) <- tmp.pnames
      rownames(return.value[[g]]) <- tmp.rownames[[g]]
    }

    # add class
    if (add.class) {
      class(return.value[[g]]) <- c("lavaan.matrix", "matrix")
    }

  } # ngroups

  # drop list?
  if (lavmodel@ngroups == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else {
    if (length(lavdata@group.label) > 0L) {
      names(return.value) <- unlist(lavdata@group.label)
    }
  }

  return.value
}

lav_object_inspect_zero_cell_tables <-                          # nolint
  function(object, add.labels = FALSE, add.class = FALSE,
            drop.list.single.group = FALSE) {
  # categorical?
  if (!object@Model@categorical) {
    lav_msg_warn(gettext("no categorical variables in fitted model"))
    return(invisible(list()))
  }

  lavdata <- object@Data

  # create 2-way tables
  tmp.table <- lavTables(object, dimension = 2L, output = "data.frame",
    statistic = NULL)

  # select tables with empty cells
  empty.id <- tmp.table$id[which(tmp.table$obs.freq == 0)]


  if (length(empty.id) == 0L) {
    # only when lavInspect() is used, give message
    if (add.class) {
      cat("(There are no tables with empty cells for this fitted model)\n")
    }
    return(invisible(list()))
  } else {
    return.value <- lav_tables_cells_format(
      tmp.table[tmp.table$id %in% empty.id, ],
      lavdata = lavdata,
      drop.list.single.group = drop.list.single.group)
  }

  return.value
}

lav_object_inspect_coef <- function(object, type = "free",
                                    add.labels = FALSE, add.class = FALSE) {

  if (type == "user" || type == "all") {
    type <- "user"
    idx <- seq_along(object@ParTable$lhs)
  } else if (type == "free") {
    #idx <- which(object@ParTable$free > 0L & !duplicated(object@ParTable$free))
    idx <- which(object@ParTable$free > 0L)
  } else {
    lav_msg_stop(gettextf(
      "%1$s argument must be either %2$s or %3$s",
      "type", "free", "user"))
  }
  tmp.est <- lav_object_inspect_est(object)
  cof <- tmp.est[idx]

  # labels?
  if (add.labels) {
    names(cof) <- lav_partable_labels(object@ParTable, type = type)
  }

  # class
  if (add.class) {
    class(cof) <- c("lavaan.vector", "numeric")
  }

  cof
}

lav_object_inspect_npar <- function(object, ceq = FALSE) {

  # free parameters (going to the optimizer)
  npar <- object@Model@nx.free

  # account for equality constraints?
  if (ceq && nrow(object@Model@con.jac) > 0L) {
    ceq.idx <- attr(object@Model@con.jac, "ceq.idx")
    if (length(ceq.idx) > 0L) {
      neq <- qr(object@Model@con.jac[ceq.idx, , drop = FALSE])$rank
      npar <- npar - neq
    }
  }

  npar
}

lav_object_inspect_icc <- function(object, add.labels = FALSE,
                                   add.class = FALSE,
                                   drop.list.single.group = FALSE) {

  lavdata <- object@Data
  n.g <- lavdata@ngroups
  return.value <- vector("list", n.g)

  # clustered data?
  if (length(lavdata@cluster) == 0L) {
    lav_msg_stop(gettext(
      "intraclass correlation only available for clustered data"))
  } else if (lavdata@nlevels == 1L) {
    lav_msg_stop(gettext(
      "intraclass correlation only available if the model syntax
       contains levels"))
  }

  if (length(object@h1) == 0L) {
    lav_msg_stop(gettext("h1 slot is not available; refit with h1 = TRUE"))
  }

  # implied statistics
  implied <- object@h1$implied

  for (g in 1:n.g) {
    sigma.w <- implied$cov[[(g - 1) * lavdata@nlevels + 1]]
    sigma.b <- implied$cov[[(g - 1) * lavdata@nlevels + 2]]

    w.diag <- diag(sigma.w)
    b.diag <- diag(sigma.b)

    return.value[[g]] <- numeric(length(w.diag))

    ov.names.l <- lavdata@ov.names.l[[g]]
    w.idx <- which(ov.names.l[[1]] %in% ov.names.l[[2]])
    w.names <- ov.names.l[[1]][w.idx]
    b.idx <- match(w.names, ov.names.l[[2]])

    return.value[[g]][w.idx] <- b.diag[b.idx] / (w.diag[w.idx] + b.diag[b.idx])

    # label
    if (add.labels) {
      names(return.value[[g]]) <- ov.names.l[[1]]
    }

    # class
    if (add.class) {
      class(return.value[[g]]) <- c("lavaan.vector", "numeric")
    }
  } # g

  if (n.g == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else {
    if (length(object@Data@group.label) > 0L) {
      names(return.value) <- unlist(object@Data@group.label)
    }
  }

  return.value
}

lav_object_inspect_ranef <- function(object, add.labels = FALSE,
                                     add.class = FALSE,
                                     drop.list.single.group = FALSE) {

  lavdata <- object@Data
  lavsamplestats <- object@SampleStats

  n.g <- lavdata@ngroups
  return.value <- vector("list", n.g)

  # multilevel?
  if (lavdata@nlevels == 1L) {
    lav_msg_stop(gettext(
      "random effects only available for clustered data (in the long format)"))
  }

  # implied statistics
  lavimplied <- object@implied

  for (g in 1:n.g) {

    tmp.lp <- lavdata@Lp[[g]]
    tmp.ylp <- lavsamplestats@YLp[[g]]

    # implied for this group
    group.idx <- (g - 1) * lavdata@nlevels + seq_len(lavdata@nlevels)
    implied.group <- lapply(lavimplied, function(x) x[group.idx])

    # random effects (=random intercepts or cluster means)
    out <- lav_mvnorm_cluster_implied22l(Lp = tmp.lp, implied = implied.group)
    mb.j <- lav_mvnorm_cluster_em_estep_ranef(YLp = tmp.ylp, Lp = tmp.lp,
      sigma.w = out$sigma.w, sigma.b = out$sigma.b,
      sigma.zz = out$sigma.zz, sigma.yz = out$sigma.yz,
      mu.z = out$mu.z, mu.w = out$mu.w, mu.b = out$mu.b,
      se = FALSE)
    return.value[[g]] <- mb.j

    ov.names.l <- lavdata@ov.names.l[[g]]

    # label
    if (add.labels) {
      colnames(return.value[[g]]) <- ov.names.l[[1]]
    }

    # class
    if (add.class) {
      class(return.value[[g]]) <- c("lavaan.matrix", "matrix")

    }
  } # g

  if (n.g == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else {
    if (length(object@Data@group.label) > 0L) {
      names(return.value) <- unlist(object@Data@group.label)
    }
  }

  return.value
}

# casewise loglikelihood contributions
lav_object_inspect_loglik_casewise <- function(object, log. = TRUE, # nolint
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {

  lavdata <- object@Data
  lavsamplestats <- object@SampleStats
  lavimplied <- object@implied
  lavoptions <- object@Options

  n.g <- lavdata@ngroups
  return.value <- vector("list", n.g)

  # multilevel?
  if (lavdata@nlevels > 1L) {
    lav_msg_stop(gettext(
  "casewise (log)likeloods contributions not yet available for clustered data"))
  }

  # estimator ML?
  if (object@Options$estimator != "ML") {
    lav_msg_stop(gettextf(
      "casewise (log)likeloods contributions only available for estimator = %s",
      dQuote("ML")))
  }

  for (g in 1:n.g) {

    if (lavsamplestats@missing.flag) {
      return.value[[g]] <-
        lav_mvnorm_missing_llik_casewise(Y = lavdata@X[[g]],
          wt = lavdata@weights[[g]],
          Mu = lavimplied$mean[[g]],
          Sigma = lavimplied$cov[[g]],
          x.idx  = lavsamplestats@x.idx[[g]])
    } else { # single-level, complete data
      if (lavoptions$conditional.x) {
        if (!is.null(lavdata@weights[[g]])) {
          lav_msg_stop(gettext("no support (yet) if weights are used."))
        }
        return.value[[g]] <- lav_mvreg_loglik_data(
          Y          = lavdata@X[[g]],
          eXo        = lavdata@eXo[[g]],
          res.int    = lavimplied$res.int[[g]],
          res.slopes = lavimplied$res.slopes[[g]],
          res.cov    = lavimplied$res.cov[[g]],
          casewise   = TRUE)

      } else {

        if (object@Model@meanstructure) {
          tmp.mean <- lavimplied$mean[[g]]
        } else {
          tmp.mean <- lavsamplestats@mean[[g]]
        }
        return.value[[g]] <-
          lav_mvnorm_loglik_data(Y  = lavdata@X[[g]],
            wt = lavdata@weights[[g]],
            Mu = tmp.mean,
            Sigma = lavimplied$cov[[g]],
            x.idx = lavsamplestats@x.idx[[g]],
            casewise = TRUE)
      }
    } # single-level, complete data

    # log. = FALSE?
    if (!log.) {
      return.value[[g]] <- exp(return.value[[g]])
    }

    # label
    # if(add.labels) {
    # }

    # class
    if (add.class) {
      class(return.value[[g]]) <- c("lavaan.vector", "numeric")

    }

  } # g

  if (n.g == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else {
    if (length(object@Data@group.label) > 0L) {
      names(return.value) <- unlist(object@Data@group.label)
    }
  }

  return.value
}

# Mahalanobis distances for factor scores or casewise residuals
# type = "lv" -> factor scores
# type = "resid" -> casewise residuals
#
# we always use Bartlett factor scores (see Yuan & Hayashi 2010)
# (this has no impact on the m-distances for the factor scores,
#  and only a very slight impact on the m-distances for the casewise
#  residuals; but asymptotically, only when we use Bartlett factor
#  scores are the 'true scores' (=LAMBDA %*% FS) orthogonal to the
#  casewise residuals)
lav_object_inspect_mdist2 <- function(object, type = "resid", squared = TRUE,
                                      add.labels = FALSE, add.class = FALSE,
                                      drop.list.single.group = FALSE) {

  lavdata <- object@Data
  n.g <- lavdata@ngroups

  # lavPredict()
  out <- lavPredict(object, type = type, method = "ML", # = Bartlett
    label = FALSE, fsm = TRUE, mdist = TRUE,
    se = "none", acov = "none")
  return.value <- attr(out, "mdist")

  for (g in seq_len(n.g)) {
    # squared?
    if (!squared) {
      return.value[[g]] <- sqrt(return.value[[g]])
    }

    # labels?
    # if(add.labels) {
    # }

    # class
    if (add.class) {
      class(return.value[[g]]) <- c("lavaan.vector", "numeric")
    }
  } # g

  if (n.g == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else {
    if (length(object@Data@group.label) > 0L) {
      names(return.value) <- unlist(object@Data@group.label)
    }
  }

  return.value
}

# N versus N-1 (or N versus N-G in the multiple group setting)
# Changed 0.5-15: suggestion by Mark Seeto
lav_object_inspect_ntotal <- function(object) {
  if (object@Options$estimator %in% c("ML", "PML", "FML", "catML") &&
    object@Options$likelihood %in% c("default", "normal")) {
    N <- object@SampleStats@ntotal
  } else {
    N <- object@SampleStats@ntotal - object@SampleStats@ngroups
  }

  N
}

lav_object_inspect_iv <- function(object, drop.list.single.group = FALSE) {
  
  if (is.null(object@internal$eqs)) {
    lav_msg_stop(gettext("no equations/ivs found"))
  }
  lavmodel <- object@Model
  lavdata <- object@Data
  
  # grab equations
  iv_list <- object@internal$eqs

  # nblocks
  nblocks <- object@pta$nblocks

  table <- vector("list", length = nblocks)
  for (b in seq_len(nblocks)) {
    eqs <- iv_list[[b]]
    lhs <- sapply(eqs, "[[", "lhs")
    rhs <- sapply(lapply(eqs, "[[", "rhs"), paste, collapse = " + ")
    lhs_new <- sapply(eqs, "[[", "lhs_new")
    rhs_new <- sapply(lapply(eqs, "[[", "rhs_new"), paste, collapse = " + ")
    miiv <- sapply(lapply(eqs, "[[", "miiv"), paste, collapse = ", ")
    table[[b]] <- data.frame(
      lhs = lhs, rhs = rhs,
      lhs.new = lhs_new, rhs.new = rhs_new, instruments = miiv
    )
    class(table[[b]]) <- c("lavaan.data.frame", "data.frame")
  }

  # return value
  return.value <- table

  # drop list?
  if (lavmodel@ngroups == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (!is.null(lavdata)) {
    if (length(lavdata@group.label) > 0L) {
      names(return.value) <- unlist(lavdata@group.label)
    }
  }

  return.value
}

lav_object_inspect_eqs <- function(object, drop.list.single.group = FALSE) {
  
  if (is.null(object@internal$eqs)) {
    lav_msg_stop(gettext("no equations/ivs found"))
  }     
  lavmodel <- object@Model
  lavdata <- object@Data
  
  # grab equations
  eqs <- object@internal$eqs

  # return value
  return.value <- eqs

  # drop list?
  if (lavmodel@ngroups == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (!is.null(lavdata)) {
    if (length(lavdata@group.label) > 0L) {
      names(return.value) <- unlist(lavdata@group.label)
    }
  }

  return.value
}

lav_object_inspect_sargan <- function(object, drop.list.single.group = FALSE) {

  if (is.null(object@internal$eqs)) {
    lav_msg_stop(gettext("no equations/ivs found"))
  }
  lavmodel <- object@Model
  lavdata <- object@Data

  # grab equations
  iv_list <- object@internal$eqs

  # nblocks
  nblocks <- object@pta$nblocks

  table <- vector("list", length = nblocks)
  for (b in seq_len(nblocks)) {
    eqs <- iv_list[[b]]
    lhs <- sapply(eqs, "[[", "lhs")
    rhs <- sapply(lapply(eqs, "[[", "rhs"), paste, collapse = " + ")
    miiv <- sapply(lapply(eqs, "[[", "miiv"), paste, collapse = ", ")
    sargan.stat <- sapply(seq_along(eqs),
      function(x) eqs[[x]][["sargan"]]["stat"])
    sargan.df <- sapply(seq_along(eqs),
      function(x) eqs[[x]][["sargan"]]["df"])
    sargan.pvalue <- sapply(seq_along(eqs),
      function(x) eqs[[x]][["sargan"]]["pvalue"])
    table[[b]] <- data.frame(
      lhs = lhs, rhs = rhs, instruments = miiv, 
      sargan.stat = sargan.stat, df = sargan.df, pvalue = sargan.pvalue
    )

    # remove rows for which the Sargan statistic is NA
    na.idx <- which(is.na(sargan.stat))
    if (length(na.idx) > 0L) {
      table[[b]] <- table[[b]][-na.idx, , drop = FALSE]
    }

    class(table[[b]]) <- c("lavaan.data.frame", "data.frame")
  }

  # return value
  return.value <- table

  # drop list?
  if (lavmodel@ngroups == 1L && drop.list.single.group) {
    return.value <- return.value[[1]]
  } else if (!is.null(lavdata)) {
    if (length(lavdata@group.label) > 0L) {
      names(return.value) <- unlist(lavdata@group.label)
    }
  }

  return.value
}



# New version of parser, written by Luc De Wilde in september/october 2023

# ----------------------- lav_create_enum ------------------------------------ #
# function to create an Enumerable like structure in R
#  usage example  mycolors <- lav_create_enum(c("black", "white",
#                                     "orange", "green", "red", "blue"))
#                 xyz <- mycolors$red
# values are default 1L, ..., number of names, but can be user specified
# ---------------------------------------------------------------------------- #
lav_create_enum <- function(names, values = seq_along(names)) {
  stopifnot(identical(unique(names), names), is.character(names))
  stopifnot(length(names) == length(values))
  res <- as.list(setNames(values, names))
  res$enum.names <- names
  res$enum.values <- values
  res$enum.size <- length(values)
  res <- as.environment(res)
  lockEnvironment(res, bindings = TRUE)
  res
}

# ------------------------ lav_parse_sublist --------------------------------- #
# function to create a list with only some indexes for all members
# ---------------------------------------------------------------------------- #
lav_parse_sublist <- function(inlist, indexes) {
  for (j in seq_along(inlist)) {
    inlist[[j]] <- inlist[[j]][indexes]
  }
  inlist
}

# ------------------------ lav_parse_eval_r_expression ------------------- #
# help function to evaluate the value of an r expression formed by the elements
# with index 'from' to 'to' of a formula 'formul1'
# returns "_error_" if evaluation failed
# used only in lav_parse_modifier
# ---------------------------------------------------------------------------- #
lav_parse_eval_r_expression <- function(formul1, from, to, types) {
  strings <- vapply(seq.int(from, to), function(x) {
    if (formul1$elem.type[x] == types$stringliteral) {
      paste0('"', formul1$elem.text[x], '"')
    } else {
      formul1$elem.text[x]
    }
  }, "")
  txt <- paste(strings, collapse = "")
  result <- try(eval(parse(text = txt),
    envir = NULL,
    enclos = baseenv()
  ), silent = TRUE)
  if (inherits(result, "try-error")) {
    return("_error_")
  }
  result
}
# ------------------------ lav_parse_txtloc  --------------------------------- #
# function which translates a position in the model source string to a
# user friendly locator (=[1L]) and the line with position (=[2L])
# ---------------------------------------------------------------------------- #
lav_parse_txtloc <- function(modelsrc, position) {
  txt <- c("", "")
  if (nchar(modelsrc) >= position && position > 0) {
    newlines <- gregexpr("\n", paste0(modelsrc, "\n"), fixed = TRUE)[[1]]
    lijn <- which(newlines >= position)[1]
    if (lijn == 1L) {
      pos <- position
      lijnchar <- substr(modelsrc, 1L, newlines[1])
    } else {
      pos <- position - newlines[lijn - 1L]
      lijnchar <- substr(modelsrc, newlines[lijn - 1L] + 1L, newlines[lijn])
    }
    if (nchar(lijnchar) == 1L) {
      lijnchar <- ""
    } else {
      lijnchar <- substr(lijnchar, 1L, nchar(lijnchar) - 1)
    }
    # adapt line number when first line blank :
    if (grepl("^[ \t]*\n", modelsrc)) lijn <- lijn - 1L
    txt <- c(
      gettextf(" at line %1$s, pos %2$s", lijn, pos),
      paste(lijnchar, "\n", strrep(" ", pos - 1L), "^\n", sep = "")
    )
  }
  txt
}

# ------------------------ lav_parse_text_tokens ----------------------------- #
# function to split the model source in tokens.
# Returns a list with tokens with their attributes
#   elem.pos  : position in source
#   elem.type : type of token (cf. definition of types
#               in lav_parse_model_string)
#   elem.text : the text of the token
#   elem.formule.number : sequence number of the 'logical'
#                         formula where the token occurs
# the function returns the stored tokens in a list
# ---------------------------------------------------------------------------- #
lav_parse_text_tokens <- function(modelsrc, types) {
  nmax <- nchar(modelsrc)
  elem.pos <- vector("integer", nmax)
  elem.type <- elem.pos
  elem.text <- vector("character", nmax)
  elem.i <- 1L
  modelsrcw <- paste0(modelsrc, "\n") # working model, must end
  # with a newline for tests via regexpr
  stringliterals <- gregexpr("\"[^\"]*?[\"\n]", modelsrcw)[[1L]]
  if (stringliterals[1L] > -1L) {
    stringliteral.lengths <- attr(stringliterals, "match.length")
    for (i in seq_along(stringliterals)) {
      pfpos <- stringliterals[i]
      pflen <- stringliteral.lengths[i]
      substr(modelsrcw, pfpos + 1L, pfpos + pflen - 2L) <-
        strrep(" ", pflen - 2L)
      elem.pos[elem.i] <- pfpos
      elem.text[elem.i] <- substr(modelsrc, pfpos + 1L, pfpos + pflen - 2L)
      elem.type[elem.i] <- types$stringliteral
      elem.i <- elem.i + 1L
    }
  }
  comments <- gregexpr("[#!].*?\n", modelsrcw)[[1L]]
  if (comments[1] > -1L) {
    comment.lengths <- attr(comments, "match.length")
    for (i in seq_along(comments)) {
      substr(modelsrcw, comments[i], comments[i] + comment.lengths[i] - 1L) <-
        strrep(" ", comment.lengths[i] - 1L)
      # check for stringliterals in comment
      str.in.comment <- (elem.pos > comments[i] &
        elem.pos < comments[i] + comment.lengths[i])
      if (any(str.in.comment)) {
        elem.type[str.in.comment] <- 0
      }
    }
  }
  modelsrcw <- gsub("\t", " ", modelsrcw)
  newlines <- gregexpr("[;\n]", modelsrcw)[[1L]]
  if (newlines[1L] > -1L) {
    for (i in seq_along(newlines)) {
      pfpos <- newlines[i]
      substr(modelsrcw, pfpos, pfpos) <- "\n"
      elem.pos[elem.i] <- pfpos
      elem.text[elem.i] <- "\n"
      elem.type[elem.i] <- types$newline
      elem.i <- elem.i + 1L
    }
  }
  # --------------------- handling spaces in operators ----------------------- #
  if (grepl("= +~", modelsrcw)) {
    waar <- regexpr("= +~", modelsrcw)[1]
    modelsrcw <- gsub("=( +)~", "=~\\1", modelsrcw)
    tl <- lav_parse_txtloc(modelsrc, waar)
    lav_msg_warn(gettext("splitting of '=~' deprecated"),
      tl[1L],
      footer = tl[2L]
    )
  }
  if (grepl("[^=~]~ +~", modelsrcw)) {
    waar <- regexpr("[^=~]~ +~", modelsrcw)[1]
    modelsrcw <- gsub("([^=~])~( +)~", "\\1~~\\2", modelsrcw)
    tl <- lav_parse_txtloc(modelsrc, waar + 1L)
    lav_msg_warn(gettext("splitting of '~~' deprecated"),
      tl[1L],
      footer = tl[2L]
    )
  }
  # -------------------------------------------------------------------------- #
  lavops <- gregexpr("=~|<~|~\\*~|~~|~|\\|~|==|<|>|:=|:|\\||%", modelsrcw)[[1]]
  if (lavops[1L] > -1L) {
    lavop.lengths <- attr(lavops, "match.length")
    for (i in seq_along(lavops)) {
      pfpos <- lavops[i]
      pflen <- lavop.lengths[i]
      elem.pos[elem.i] <- pfpos
      elem.text[elem.i] <- substr(modelsrcw, pfpos, pfpos + pflen - 1L)
      elem.type[elem.i] <- types$lavaanoperator
      substr(modelsrcw, pfpos, pfpos + pflen - 1L) <- strrep(" ", pflen)
      elem.i <- elem.i + 1L
    }
  }
  symbols <- gregexpr("[,()/*?^']", modelsrcw)[[1L]] # f1=~x2 + 0.5 ? x3
  symbols1 <- gregexpr("[-+][^.0-9]", modelsrcw)[[1L]] # f1=~x2+x3
  symbols2 <- gregexpr("[._0-9a-df-zA-DF-Z)] *[-+][.0-9]", modelsrcw)[[1L]]
  # f1=~x2+2*x3, len-2 !
  symbols3 <- gregexpr("[^.0-9][eE] *[-+][.0-9]", modelsrcw)[[1L]]
  # f1=~xe+2*x3, len-2 !
  if (symbols1[1L] > -1L) {
    if (symbols[1L] == -1L) {
      symbols <- symbols1
    } else {
      symbols <- c(symbols, symbols1)
    }
  }
  if (symbols2[1L] > -1L) {
    symbols2.lengths <- attr(symbols2, "match.length")
    symbols2 <- symbols2 + symbols2.lengths - 2L
    if (symbols[1L] == -1L) {
      symbols <- symbols2
    } else {
      symbols <- c(symbols, symbols2)
    }
  }
  if (symbols3[1L] > -1L) {
    symbols3.lengths <- attr(symbols3, "match.length")
    symbols3 <- symbols3 + symbols3.lengths - 2L
    if (symbols[1L] == -1L) {
      symbols <- symbols3
    } else {
      symbols <- c(symbols, symbols3)
    }
  }
  if (symbols[1L] > -1L) {
    for (i in seq_along(symbols)) {
      pfpos <- symbols[i]
      substr(modelsrcw, pfpos, pfpos) <- " "
      elem.pos[elem.i] <- pfpos
      elem.text[elem.i] <- substr(modelsrc, pfpos, pfpos)
      elem.type[elem.i] <- types$symbol
      elem.i <- elem.i + 1L
    }
  }

  numliterals <- gregexpr(
    "([ \n][-+][.0-9]|[ \n]\\.[0-9]|[ \n][0-9])[-+\\.0-9eE]*",
    paste0(" ", modelsrcw)
  )[[1]]
  if (numliterals[1L] > -1L) {
    numliteral.lengths <- attr(numliterals, "match.length") - 1L
    for (i in seq_along(numliterals)) {
      pfpos <- numliterals[i]
      pflen <- numliteral.lengths[i]
      substr(modelsrcw, pfpos, pfpos + pflen - 1L) <- strrep(" ", pflen)
      elem.pos[elem.i] <- pfpos
      elem.text[elem.i] <- substr(modelsrc, pfpos, pfpos + pflen - 1L)
      elem.type[elem.i] <- types$numliteral
      elem.i <- elem.i + 1L
    }
  }
  identifiers <- gregexpr("[ \n][_.[:alpha:]][_.[:alnum:]]*",
                 paste0(" ", modelsrcw)
  )[[1]]
  identifier.lengths <- attr(identifiers, "match.length") - 1L
  for (i in seq_along(identifiers)) {
    pfpos <- identifiers[i]
    pflen <- identifier.lengths[i]
    substr(modelsrcw, pfpos, pfpos + pflen - 1L) <- strrep(" ", pflen)
    elem.pos[elem.i] <- pfpos
    elem.text[elem.i] <- substr(modelsrc, pfpos, pfpos + pflen - 1L)
    elem.type[elem.i] <- types$identifier
    elem.i <- elem.i + 1L
  }
  # check for uninterpreted chars
  wrong <- regexpr("[^\"\n ]", modelsrcw)
  if (wrong != -1L) {
    tl <- lav_parse_txtloc(modelsrc, wrong)
    lav_msg_stop(gettext("unexpected character"),
      tl[1L],
      footer = tl[2L]
    )
  }
  # remove unused elements from vectors
  elements <- which(elem.type > 0L)
  elem.pos <- elem.pos[elements]
  elem.type <- elem.type[elements]
  elem.text <- elem.text[elements]
  # order tokens
  token.order <- order(elem.pos)
  elem.pos <- elem.pos[token.order]
  elem.type <- elem.type[token.order]
  elem.text <- elem.text[token.order]

  # concatenate identifiers with only spaces in between - LDW 22/4/2024
  elem.i <- length(elem.pos)
  concatenated <- FALSE
  while (elem.i > 1L) {
    if (any(elem.type[elem.i] == c(types$identifier, types$numliteral)) &&
      elem.type[elem.i - 1L] == types$identifier) {
      spaces.between <- elem.pos[elem.i] - elem.pos[elem.i - 1L] -
        length(elem.text[elem.i - 1L])
      elem.text[elem.i - 1L] <- paste0(
        elem.text[elem.i - 1L],
        strrep(" ", spaces.between),
        elem.text[elem.i]
      )
      elem.type[elem.i] <- 0L
      concatenated <- TRUE
    }
    elem.i <- elem.i - 1L
  }
  if (concatenated) { # remove items with type 0
    elements <- which(elem.type > 0L)
    elem.pos <- elem.pos[elements]
    elem.type <- elem.type[elements]
    elem.text <- elem.text[elements]
  }

  # to set formula number
  elem.formula.number <- rep(0L, length(elem.type))
  frm.number <- 1L
  frm.hasefa <- FALSE
  frm.lastplus <- FALSE
  frm.incremented <- FALSE
  for (i in seq_along(elem.type)) {
    elem.formula.number[i] <- frm.number
    if (elem.type[i] == types$identifier && elem.text[i] == "efa") {
      frm.hasefa <- TRUE
    }
    if (any(elem.text[i] == 
      c("+", "*", "=~", "-", "<~", "~*~", "~~", "~", "|~", "|", "%"))) {
      if (frm.incremented) {
        frm.number <- frm.number - 1L
        elem.formula.number[i] <- frm.number
        frm.incremented <- FALSE
      }
      frm.lastplus <- TRUE
    } else {
      if (any(elem.type[i] == c(
        types$stringliteral, types$identifier, types$numliteral,
        types$stringliteral, types$symbol
      ))) {
        frm.lastplus <- FALSE
      }
      if (i > 1 && elem.type[i] != types$newline &&
        elem.type[i - 1L] == types$lavaanoperator) {
        frm.hasefa <- FALSE
      }
    }
    if (elem.type[i] == types$newline) {
      if (i > 1 && elem.type[i - 1L] != types$newline) { # ignore multiple nl's
        if (!frm.hasefa && !frm.lastplus) {
          frm.number <- frm.number + 1L
          frm.incremented <- TRUE
        } else {
          frm.hasefa <- FALSE
        }
      }
    } else {
      frm.incremented <- FALSE
    }
  }
  list(
    elem.pos = elem.pos, elem.type = elem.type,
    elem.text = elem.text, elem.formula.number = elem.formula.number
  )
}

# ------------------------ lav_parse_tokens_formulas ------------------------- #
# function to group the modellist tokens in 'mono' formulas.
# mono means that the terms (for formulas other then blocks and constraints)
#   are split in seperate formula's, e.g.
#   a1 + a2 =~ b1 + b2  becomes
#     /  a1 =~ b1
#     |  a1 =~ b2
#     |  a2 =~ b1
#     \  a2 =~ b2
# newlines are removed
# the function returns a list of formulas
# ---------------------------------------------------------------------------- #
lav_parse_tokens_formulas <- function(modellist, modelsrc, types) {
  real.operators <- c("=~", "<~", "~*~", "~~", "~", "|~", "|", "%")
  welke <- modellist$elem.type != types$newline
  formula.numbers <- unique(modellist$elem.formula.number[welke])
  formulas <- lapply(formula.numbers, function(s) {
    welkenu <- modellist$elem.formula.number == s & welke
    list(
      elem.pos = modellist$elem.pos[welkenu],
      elem.type = modellist$elem.type[welkenu],
      elem.text = modellist$elem.text[welkenu]
    )
  })
  maxnum <- length(formula.numbers) + sum(modellist$elem.text == "+")
  outval <- vector(mode = "list", length = maxnum)
  realnum <- 0L
  for (i in seq_along(formulas)) {
    formul1 <- formulas[[i]]
    opi <- which(formul1$elem.type == types$lavaanoperator)
    nelem <- length(formul1$elem.type)
    if (length(opi) == 0L) {
      tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[1])
      lav_msg_stop(gettext("formula without valid operator"),
        tl[1L],
        footer = tl[2L]
      )
    }
    if (length(opi) > 1L) opi <- opi[1] # only first operator taken
    if (any(formul1$elem.text[opi] == real.operators) &&
      sum(formul1$elem.text == "+") > 0) {
      # check + symbols outside parentheses in left and right hand side
      lhplusjes <- integer(0)
      openparentheses <- 0L
      for (jj in seq.int(1L, opi - 1L)) {
        if (formul1$elem.text[jj] == "(") {
          openparentheses <- openparentheses + 1L
          next
        }
        if (formul1$elem.text[jj] == ")") {
          openparentheses <- openparentheses - 1L
          next
        }
        if (formul1$elem.text[jj] == "+" && openparentheses == 0L) {
          lhplusjes <- c(lhplusjes, jj)
        }
      }
      lhplusjes <- c(lhplusjes, opi)
      plusjes <- integer(0)
      openparentheses <- 0L
      for (jj in seq.int(opi + 1L, nelem)) {
        if (formul1$elem.text[jj] == "(") {
          openparentheses <- openparentheses + 1L
          next
        }
        if (formul1$elem.text[jj] == ")") {
          openparentheses <- openparentheses - 1L
          next
        }
        if (formul1$elem.text[jj] == "+" && openparentheses == 0L) {
          plusjes <- c(plusjes, jj)
        }
      }
      plusjes <- c(plusjes, nelem + 1)
      # splitting lhs and rhs on '+' signs
      for (j in seq_along(lhplusjes)) {
        j0 <- 1L
        if (j > 1L) j0 <- lhplusjes[j - 1L] + 1L
        j1 <- lhplusjes[j] - 1L
        if (j1 < j0) next # skip empty parts
        for (k in seq_along(plusjes)) {
          k0 <- opi + 1L
          k1 <- plusjes[k] - 1L
          if (k > 1L) k0 <- plusjes[k - 1L] + 1L
          if (k1 < k0) next # skip empty parts
          welke <- c(seq.int(j0, j1), opi, seq.int(k0, k1))
          realnum <- realnum + 1L
          outval[[realnum]] <- lav_parse_sublist(formul1, welke)
        }
      }
    } else {
      realnum <- realnum + 1L
      outval[[realnum]] <- formul1
    }
  }
  outval[seq_len(realnum)]
}
# ------------------------ lav_parse_check_name ------------------------ #
# checks if an element of the elem.text member in a list is a valid r-name
# ---------------------------------------------------------------------------- #
lav_parse_check_name <- function(formul1, ind, modelsrc) {
  # allow spaces, LDW 22/4/2024
  testitem <- gsub(" ", "_", formul1$elem.text[ind], fixed = TRUE)

  if (make.names(testitem) != testitem) {
    tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[ind])
    lav_msg_stop(
      gettext("identifier is either a reserved word (in R) or
              contains an illegal character"),
      tl[1L],
      footer = tl[2L]
    )
  }
  invisible(NULL)
}
# ------------------------ lav_parse_modifier ---------------------------- #
# The function takes a list with tokens belonging to a single 'mono' lavaan
# formula as input. The other arguments are:
#       lhs : check for lhs or rhs modifier
#       opi : index of the lavaan operator in the list-items
#  modelsrc : the model source string (for error messages and warnings)
#     types : the types of tokens
#       rme : index of last element of modifier in formula (*)
#   rmeprev : index of first element of modifier in formula - 1L (*)
# The function return the modifier detected as element of a list
#  with name the modifier type (efa, fixed, start, label, lower, upper, prior or
#   rv) and value an array of values (length > 1 if vector via c(...)) for the
#   modifier value.
# (*) if rme > remprev the rhs is limited to the elements with index
#     rmeprev+1:rme, this is to support multiple modifiers for the same element.
# An error message is produced when no modifier can be determined.
# ---------------------------------------------------------------------------- #
lav_parse_modifier <- function(formul1, lhs, opi, modelsrc, types,
                                   rme = 0L, rmeprev = 0L, modenv) {
  if (rme > rmeprev) {
    welke <- c(seq.int(1L, opi), seq.int(rmeprev + 1L, rme),
               length(formul1$elem.type))
    formul1 <- lav_parse_sublist(formul1, welke)
  }
  nelem <- length(formul1$elem.type)
  # remove unnecessary parentheses (one element between parentheses, previous
  # no identifier)
  check.more <- TRUE
  while (check.more && nelem > 4L) {
    check.more <- FALSE
    for (par.i in seq.int(3L, nelem - 1L)) {
      if (formul1$elem.text[par.i - 1L] == "(" &&
        formul1$elem.text[par.i + 1L] == ")" &&
        formul1$elem.type[par.i - 2L] != types$identifier) {
        formul1$elem.type[par.i - 1L] <- 0L
        formul1$elem.type[par.i + 1L] <- 0L
        check.more <- TRUE
      }
    }
    if (check.more) {
      formul1 <- lav_parse_sublist(formul1, which(formul1$elem.type > 0))
      nelem <- length(formul1$elem.type)
    }
  }
  if (lhs) {
    # modifier on left hand side
    # only 1 possibility : efa ( expression-resulting-in-char ) *
    #                                        identifier operator ... (rhs) ...
    if (formul1$elem.text[1L] == "efa" &&
      formul1$elem.text[2L] == "(" &&
      formul1$elem.text[opi - 3L] == ")" &&
      formul1$elem.text[opi - 2L] == "*") {
      temp <- lav_parse_eval_r_expression(formul1, 3L, opi - 4L, types)
      if (is.character(temp) && temp[1] != "_error_") {
        return(list(efa = temp))
      }
    }
    tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[1L])
    lav_msg_stop(gettext("invalid left hand side modifier"),
      tl[1L],
      footer = tl[2L]
    )
  } else {
    getmodifier <- function(s) {
      if (s %in% c("c", "t")) {
        tmp <- s
        attr(tmp, "tiepe") <- "label"
        return(tmp)
      }
      v <- all.vars(str2expression(s))
      for (v1 in v) {
        assign(v1, v1, modenv)
      }
      tmp <- eval(str2expression(s), modenv)
      rm(list = v, pos = modenv)
      if (is.null(attr(tmp, "tiepe"))) {
        if (is.numeric(tmp) || is.logical(tmp)) {
          attr(tmp, "tiepe") <- "fixed"
        } else {
          attr(tmp, "tiepe") <- "label"
        }
      }
      tmp
    }
    strings <- vapply(seq.int(opi + 1L, nelem - 2L), function(x) {
      if (formul1$elem.type[x] == types$stringliteral) {
        paste0('"', formul1$elem.text[x], '"')
      } else {
        formul1$elem.text[x]
      }
    }, "")
    txt <- paste(strings, collapse = "")
    if (formul1$elem.text[nelem - 1L] == "?") {
      formul1$elem.text[nelem - 1L] <- "*"
      txt <- paste0("start(", txt, ")")
    }
    if (formul1$elem.text[nelem - 1L] != "*") {
      tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[nelem - 1L])
      lav_msg_stop(gettext("invalid modifier symbol (should be '*' or '?')"),
        tl[1L],
        footer = tl[2L]
      )
    }
    modifier <- try(getmodifier(txt), silent = TRUE)
    if (inherits(modifier, "try-error")) {
      tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[opi + 1L])
      lav_msg_stop(gettext("invalid modifier specification"),
        tl[1L],
        footer = tl[2L]
      )
    }
    if (attr(modifier, "tiepe") == "label") {
      if (!is.character(modifier)) {
        tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[opi + 1L])
        lav_msg_stop(gettext("invalid label modifier (should be character)"),
          tl[1L],
          footer = tl[2L]
        )
      }
    } else {
      if (!is.numeric(modifier) && !all(is.na(modifier))) {
        tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[opi + 1L])
        lav_msg_stop(gettext("invalid numeric modifier"),
          tl[1L],
          footer = tl[2L]
        )
      }
    }
    modifierlist <- list(as.vector(modifier))
    names(modifierlist) <- attr(modifier, "tiepe")
    modifierlist
  }
}

# -------------------- main parsing function --------------------------------- #
lav_parse_model_string <- function(model.syntax = "", as.data.frame. = FALSE) {
  stopifnot(length(model.syntax) > 0L)
  # replace 'strange' tildes (in some locales) (new in 0.6-6)
  modelsrc <- gsub(
    pattern = "\u02dc",
    replacement = "~",
    paste(unlist(model.syntax), "", collapse = "\n")
  )
  hashstring <- paste0("mdl_", lav_char2hash(paste0(modelsrc, as.data.frame.)))
  if (exists(hashstring, envir = lavaan_cache_env)) {
    return(get(hashstring, envir = lavaan_cache_env))
  }
  modenv <- new.env()
assign("label", function(...) {
    x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "label"; x
  }, modenv)
assign("start", function(...) {
    x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "start"; x
  }, modenv)
assign("fixed", function(...) {
    x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "fixed"; x
  }, modenv)
assign("upper", function(...) {
    x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "upper"; x
  }, modenv)
assign("lower", function(...) {
    x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "lower"; x
  }, modenv)
assign("rv", function(...) {
    x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "rv"; x
  }, modenv)
assign("prior", function(...) {
    x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "prior"; x
  }, modenv)
assign("equal", function(...) {
    x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "label"; x
  }, modenv)
  types <- lav_create_enum(c(
    "identifier", "numliteral", "stringliteral",
    "symbol", "lavaanoperator", "newline"
  ))
  modellist <- lav_parse_text_tokens(modelsrc, types)
  if (lav_debug()) {
    print(data.frame(
      pos = modellist$elem.pos,
      type = types$enum.names[modellist$elem.type],
      text = modellist$elem.text,
      formula = modellist$elem.formula.number
    ))
  }
  formulalist <- lav_parse_tokens_formulas(modellist, modelsrc, types)
  #---- analyse syntax formulas and put in flat.-----
  max.mono.formulas <- length(formulalist)
  flat.lhs <- character(max.mono.formulas)
  flat.op <- character(max.mono.formulas)
  flat.rhs <- character(max.mono.formulas)
  flat.rhs.mod.idx <- integer(max.mono.formulas)
  flat.block <- integer(max.mono.formulas) # keep track of groups using ":" opr
  flat.fixed <- character(max.mono.formulas) # only for display purposes!
  flat.start <- character(max.mono.formulas) # only for display purposes!
  flat.lower <- character(max.mono.formulas) # only for display purposes!
  flat.upper <- character(max.mono.formulas) # only for display purposes!
  flat.label <- character(max.mono.formulas) # only for display purposes!
  flat.prior <- character(max.mono.formulas)
  flat.efa <- character(max.mono.formulas)
  flat.rv <- character(max.mono.formulas)
  flat.idx <- 0L
  mod.idx <- 0L
  constraints <- list()
  mod <- list()
  block <- 1L
  block.op <- FALSE
  if (lav_debug()) {
    cat("formula to analyse:\n")
  }
  #  operators <- c("=~", "<~", "~*~", "~~", "~", "|~", "==", "<", ">", ":=",
  #                 ":", "|", "%")
  constraint_operators <- c("==", "<", ">", ":=")
  for (s in seq_along(formulalist)) {
    formul1 <- formulalist[[s]]
    if (lav_debug()) {
      cat(vapply(seq_along(formul1$elem.type), function(j) {
        if (formul1$elem.type[j] == types$stringliteral) {
          return(dQuote(formul1$elem.text[j], FALSE))
        }
        formul1$elem.text[j]
      }, ""), "\n")
    }
    nelem <- length(formul1$elem.type)
    # where is the operator
    opi <- which(formul1$elem.type == types$lavaanoperator)
    if (length(opi) > 1L) { # if more then 1 operator skip operators ':'
      opii <- 1L
      while (formul1$elem.text[opi[opii]] == ":" && opii < length(opi)) {
        opii <- opii + 1L
      }
      opi <- opi[opii]
    }
    op <- formul1$elem.text[opi]
    if (any(op == constraint_operators)) { # ----- constraints -------
      lhs <- paste(formul1$elem.text[seq.int(1L, opi - 1L)], collapse = "")
      rhs <- paste(formul1$elem.text[seq.int(opi + 1L, nelem)], collapse = "")
      constraints <- c(
        constraints,
        list(list(
          op = op,
          lhs = lhs,
          rhs = rhs,
          user = 1L
        ))
      )
      next
    }
    if (op == ":") { # ------------------------- block start ----------------- #
      if (opi == 1L) {
        tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[1])
        lav_msg_stop(
          gettext(
          "Missing block identifier. The correct syntax is: \"LHS: RHS\",
          where LHS is a block identifier (eg group or level), and RHS is
          the group/level/block number or label."
          ), tl[1L], footer = tl[2L]
        )
      }
      if (opi > 2L || all(tolower(formul1$elem.text[1]) !=
        c("group", "level", "block", "class"))) {
        tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[1])
        lav_msg_stop(
          gettext(
          "Invalid block identifier. The correct syntax is: \"LHS: RHS\",
          where LHS is a block identifier (eg group or level), and RHS is
          the group/level/block number or label."
          ),
          tl[1L], footer = tl[2L]
        )
      }
      if (nelem != 3 || all(formul1$elem.type[3] !=
        c(types$stringliteral, types$identifier, types$numliteral))) {
        tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[1])
        lav_msg_stop(
          gettext("syntax contains block identifier \"group\" with missing or
                invalid number/label.The correct syntax is: \"LHS: RHS\", where
                LHS is a block identifier (eg group or level), and RHS is the
                group/level/block number or label."),
          tl[1L],
          footer = tl[2L]
        )
      }
      flat.idx <- flat.idx + 1L
      flat.lhs[flat.idx] <- formul1$elem.text[1]
      flat.op[flat.idx] <- op
      flat.rhs[flat.idx] <- formul1$elem.text[3]
      flat.rhs.mod.idx[flat.idx] <- 0L
      if (block.op) {
        block <- block + 1L
      } else {
        if (flat.idx != 1) {
          tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[1])
          lav_msg_warn(
            gettext("First block defined after other formula's"),
            tl[1L],
            footer = tl[2L]
          )
        }
      }
      flat.block[flat.idx] <- block
      block.op <- TRUE
      next
    }
    # ------------------ relational operators -------------------------------- #
    # warn if some identifiers contain spaces
    contsp <- which(formul1$elem.type == types$identifier &
      grepl(" ", formul1$elem.text, fixed = TRUE))
    if (length(contsp) > 0L) {
      tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[contsp[1L]])
      lav_msg_warn(
        gettextf(
          "having identifiers with spaces ('%s') is deprecated",
          formul1$elem.text[contsp[1]]
        ),
        tl[1L],
        footer = tl[2L]
      )
    }
    # checks for valid names in lhs and rhs
    lav_parse_check_name(formul1, opi - 1L, modelsrc) # valid name lhs
    for (j in seq.int(opi + 1L, nelem)) { # valid names rhs
      if (formul1$elem.type[j] == types$identifier &&
        formul1$elem.text[j] != "NA") {
        lav_parse_check_name(formul1, j, modelsrc)
      }
    }
    if (formul1$elem.type[nelem] != types$identifier &&
        (formul1$elem.type[nelem] != types$numliteral ||
         all(op != c("~", "|~", "=~")))) {
      tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[nelem])
      lav_msg_stop(
        gettext("Last element of rhs part expected to be an identifier or,
                for operator ~, |~ or =~, a numeric literal!"),
        tl[1L],
        footer = tl[2L]
      )
    }
    # intercept fixed on 0
    # replace 'lhs ~ 0' => 'lhs ~ 0 * 1' - intercept fixed on zero
    if (formul1$elem.text[nelem] == "0" && op == "~" && opi == nelem - 1L) {
      formul1$elem.type <- c(formul1$elem.type, types$symbol, types$numliteral)
      formul1$elem.text <- c(formul1$elem.text, "*", "1")
      formul1$elem.pos <- c(formul1$elem.pos, rep(formul1$elem.pos[nelem], 2))
      nelem <- length(formul1$elem.type)
    }
    # phantom latent variable
    # replace 'lhs =~ 0' => 'lhs =~ fixed(0)*lhs', 0 can be other numliteral
    #          also, lhs is last element before '=~'
    if (formul1$elem.type[nelem] == types$numliteral && op == "=~") {
      formul1$elem.type <- c(
        formul1$elem.type[seq.int(1L, nelem - 1L)], types$identifier,
        types$symbol, types$numliteral, types$symbol, types$symbol,
        types$identifier
      )
      formul1$elem.text <- c(
        formul1$elem.text[seq.int(1L, nelem - 1L)], "fixed", "(",
        formul1$elem.text[nelem], ")", "*", formul1$elem.text[opi - 1L]
      )
      formul1$elem.pos <- c(
        formul1$elem.pos[seq.int(1L, nelem - 1L)],
        rep(formul1$elem.pos[nelem], 6)
      )
      nelem <- length(formul1$elem.type)
    }
    # handling interaction variable types
    colons <- which(formul1$elem.text[seq.int(1L, nelem - 1L)] == ":" &
      formul1$elem.type[seq.int(2L, nelem)] == types$identifier)
    # check at most 1 colon
    if (length(colons) > 2L ||
        (length(colons) == 2L && (colons[1L] > opi || colons[2L] < opi))) {
      tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[colons[2]])
      lav_msg_stop(
        gettext(
        "Three-way or higher-order interaction terms (using multiple
         colons) are not supported in the lavaan syntax; please manually
         construct the product terms yourself in the data.frame, give
         them an appropriate name, and then you can use these interaction
         variables as any other (observed) variable in the model syntax."
        ), tl[1L], footer = tl[2L]
      )
    }
    if (length(colons) > 0L) {
      # collapse items around colon "a" ":" "b" => "a:b"
      formul1$elem.text[colons[1L] - 1L] <-
        paste(formul1$elem.text[seq.int(colons[1L] - 1L, colons[1L] + 1L)],
          collapse = ""
        )
      formul1 <- lav_parse_sublist(formul1,
          setdiff(seq.int(1L, nelem), seq.int(colons[1L], colons[1L] + 1L)))
      nelem <- length(formul1$elem.type)
      if (colons[1L] < opi) {
        opi <- opi - 2L # is in LHS
        if (length(colons) == 2L) colons[2L] <- colons[2L] - 2L
      }
    }
    if (length(colons) == 2L) {
      # collapse items around colon "a" ":" "b" => "a:b"
      formul1$elem.text[colons[2L] - 1L] <-
        paste(formul1$elem.text[seq.int(colons[2L] - 1L, colons[2L] + 1L)],
              collapse = ""
        )
      formul1 <- lav_parse_sublist(formul1,
          setdiff(seq.int(1L, nelem), seq.int(colons[2L], colons[2L] + 1L)))
      nelem <- length(formul1$elem.type)
    }
    # modifiers
    rhsmodelems <- which(seq_along(formul1$elem.type) > opi &
      formul1$elem.type == types$symbol &
      (formul1$elem.text == "*" | formul1$elem.text == "?"))
    for (j in seq_along(rhsmodelems)) {
      if (sum(formul1$elem.text[seq.int(opi, rhsmodelems[j])] == "(") !=
          sum(formul1$elem.text[seq.int(opi, rhsmodelems[j])] == ")"))
        rhsmodelems[j] = 0L
    }
    rhsmodelems <- rhsmodelems[rhsmodelems != 0L]
    if (length(rhsmodelems) == 0L) rhsmodelems <- opi
    lhs <- formul1$elem.text[opi - 1L]
    rhs <- formul1$elem.text[nelem]
    for (rmei in seq_along(rhsmodelems)) {
      rme <- rhsmodelems[rmei]
      rmeprev <- if (rmei == 1L) opi else rhsmodelems[rmei - 1L]
      already <- which(flat.lhs == lhs & flat.op == op & flat.block == block &
        (flat.rhs == rhs | (flat.rhs == "" & (op == "~" | op == "|~") &
          formul1$elem.type[nelem] == types$numliteral)))
      if (length(already) == 1L) {
        idx <- already
      } else {
        flat.idx <- flat.idx + 1L
        idx <- flat.idx
        flat.lhs[idx] <- lhs
        flat.op[idx] <- op
        flat.rhs[idx] <- rhs
        flat.block[idx] <- block
        if (formul1$elem.type[nelem] == types$numliteral) {
          if (op == "~" || op == "|~") flat.rhs[idx] <- ""
        }
      }
      lhsmod <- list()
      if (opi > 2 && rmei == 1L) {
        lhsmod <- lav_parse_modifier(
          formul1,
          TRUE, opi, modelsrc, types, modenv = modenv
        )
      }
      rhsmod <- list()
      if (nelem - opi > 1) {
        rhsmod <- lav_parse_modifier(
          formul1,
          FALSE, opi, modelsrc, types, rme, rmeprev, modenv = modenv
        )
      }
      flat.fixed[idx] <- if (is.null(rhsmod$fixed)) {
        flat.fixed[idx]
      } else {
        paste(rhsmod$fixed, collapse = ";")
      }
      flat.start[idx] <- if (is.null(rhsmod$start)) {
        flat.start[idx]
      } else {
        paste(rhsmod$start, collapse = ";")
      }
      flat.label[idx] <- if (is.null(rhsmod$label)) {
        flat.label[idx]
      } else {
        paste(rhsmod$label, collapse = ";")
      }
      flat.lower[idx] <- if (is.null(rhsmod$lower)) {
        flat.lower[idx]
      } else {
        paste(rhsmod$lower, collapse = ";")
      }
      flat.upper[idx] <- if (is.null(rhsmod$upper)) {
        flat.upper[idx]
      } else {
        paste(rhsmod$upper, collapse = ";")
      }
      flat.prior[idx] <- if (is.null(rhsmod$prior)) {
        flat.prior[idx]
      } else {
        paste(rhsmod$prior, collapse = ";")
      }
      flat.efa[idx] <- if (is.null(lhsmod$efa)) {
        flat.efa[idx]
      } else {
        paste(lhsmod$efa, collapse = ";")
      }
      flat.rv[idx] <- if (is.null(rhsmod$rv)) {
        flat.rv[idx]
      } else {
        paste(rhsmod$rv, collapse = ";")
      }
      modnu <- c(lhsmod, rhsmod)
      if (length(modnu) > 0L) { # there is a modifier here
        if (length(already) == 0) { # unknown element
          mod.idx <- mod.idx + 1L
          cur.mod.idx <- mod.idx
          mod[[cur.mod.idx]] <- modnu
          flat.rhs.mod.idx[idx] <- cur.mod.idx
        } else { # known element
          if (flat.rhs.mod.idx[idx] == 0) { # not yet modifier
            mod.idx <- mod.idx + 1L
            cur.mod.idx <- mod.idx
            mod[[cur.mod.idx]] <- modnu
            flat.rhs.mod.idx[idx] <- cur.mod.idx
          } else { # use existing modifier index
            cur.mod.idx <- flat.rhs.mod.idx[idx]
            overwrite <- names(modnu)[names(modnu) %in%
              names(mod[[cur.mod.idx]])]
            if (length(overwrite) > 0) {
              tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[rmeprev + 1L])
              lav_msg_warn(
                gettextf(
                  "modifier %s specified multiple times, overwritten",
                  overwrite[1L]
                ), tl[1L],
                footer = tl[2L]
              )
            }
            mod[[cur.mod.idx]] <- modifyList(mod[[cur.mod.idx]], modnu)
          }
        }
      }
    }
    # check for variable regressed on itself
    if (formul1$elem.text[opi] == "~" &&
        formul1$elem.text[opi - 1L] == formul1$elem.text[nelem]) {
      if (!grepl("^0\\.?0*$", flat.fixed[idx])) {
        tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[opi])
        lav_msg_stop(
          gettext("a variable cannot be regressed on itself"),
          tl[1L],
          footer = tl[2L]
        )
      }
    }
  }
  # create flat (omit items without operator)
  filled.ones <- which(flat.op != "")
  flat <- list(
    lhs = flat.lhs[filled.ones],
    op = flat.op[filled.ones],
    rhs = flat.rhs[filled.ones],
    mod.idx = flat.rhs.mod.idx[filled.ones],
    block = flat.block[filled.ones],
    fixed = flat.fixed[filled.ones],
    start = flat.start[filled.ones],
    lower = flat.lower[filled.ones],
    upper = flat.upper[filled.ones],
    label = flat.label[filled.ones],
    prior = flat.prior[filled.ones],
    efa = flat.efa[filled.ones],
    rv = flat.rv[filled.ones]
  )
  # change op for intercepts (for convenience only)
  int.idx <- which(flat.op == "~" & flat.rhs == "")
  if (length(int.idx) > 0L) {
    flat$op[int.idx] <- "~1"
  }
  # change op for ininstruments (for convenience only)
  int.idx <- which(flat.op == "|~" & flat.rhs == "")
  if (length(int.idx) > 0L) {
    flat$op[int.idx] <- "|~1"
  }
  # if there are constraints that are simple lower or upper limits, put
  # them in these members, add a modifier and remove constraint
  aantal <- length(constraints)
  if (aantal > 0) {
    for (j in aantal:1) {
      if (any(flat$label == constraints[[j]]$lhs) &&
          any(constraints[[j]]$op == c("<", ">"))) {
          rhslang <- str2lang(constraints[[j]]$rhs)
          numbound <- NA_real_
          if (mode(rhslang) == "numeric") {
            numbound <- as.numeric(constraints[[j]]$rhs)
          } else {
            if (mode(rhslang) == "call") {
              if (is.numeric(tryCatch(eval(rhslang),
                                      error = function(e) "error"))) {
                numbound <- eval(rhslang)
              }
            }
          }
          if (!is.na(numbound)) {
            nrs <- which(flat$label == constraints[[j]]$lhs)
            for (nr in nrs) {
              nrm <- length(mod) + 1L
              if (flat$mod.idx[nr] > 0L) {
                nrm <- flat$mod.idx[nr]
              } else {
                flat$mod.idx[nr] <- nrm
                mod <- c(mod, list(label = constraints[[j]]$lhs))
              }
              if (constraints[[j]]$op == "<") {
                flat$upper[nr] <- as.character(numbound)
                mod[[nrm]]$upper <- numbound
              } else {
                flat$lower[nr] <- as.character(numbound)
                mod[[nrm]]$lower <- numbound
              }
            }
            constraints <- constraints[-j]
          }
        }
    }
  }
  # new in 0.6, reorder covariances here!
  flat <- lav_partable_covariance_reorder(flat)
  if (as.data.frame.) {
    flat <- as.data.frame(flat, stringsAsFactors = FALSE)
  }
  # new in 0.6-4: check for 'group' within 'level'
  if (any(flat.op == ":")) {
    op.idx <- which(flat.op == ":")
    if (length(op.idx) < 2L) {
      # only 1 block identifier? this is weird -> give warning
      lav_msg_warn(gettext("syntax contains only a single block identifier!"))
    } else {
      first.block <- flat.lhs[op.idx[1L]]
      second.block <- flat.lhs[op.idx[2L]]
      if (first.block == "level" && second.block == "group") {
        lav_msg_stop(gettext("groups can not be nested within levels!"))
      }
    }
  }
  # create output
  attr(flat, "modifiers") <- mod
  attr(flat, "constraints") <- constraints
  assign(hashstring, flat, envir = lavaan_cache_env)
  flat
}

# loglikelihood clustered/twolevel data in the presence of missing data

# YR:
# - objective function: first version around March 2021 (see Psych paper)
# - analytic gradient: first version around May 2021


# Mu.W, Mu.B, Sigma.W, Sigma.B are the model-implied statistics
lav_mvnorm_cluster_missing_loglik_samplestats_2l <- function(Y1 = NULL,
                                                             Y2 = NULL,
                                                             Lp = NULL,
                                                             Mp = NULL,
                                                             Mu.W = NULL,
                                                             Sigma.W = NULL,
                                                             Mu.B = NULL,
                                                             Sigma.B = NULL,
                                                             Sinv.method = "eigen",
                                                             log2pi = FALSE,
                                                             loglik.x = 0,
                                                             minus.two = TRUE) {
  # map implied to 2l matrices
  out <- lav_mvnorm_cluster_implied22l(
    Lp = Lp, Mu.W = Mu.W, Mu.B = Mu.B,
    Sigma.W = Sigma.W, Sigma.B = Sigma.B
  )
  mu.y <- out$mu.y
  mu.z <- out$mu.z
  sigma.w <- out$sigma.w
  sigma.b <- out$sigma.b
  sigma.zz <- out$sigma.zz
  sigma.yz <- out$sigma.yz

  # Lp
  nclusters <- Lp$nclusters[[2]]
  between.idx <- Lp$between.idx[[2]]
  both.idx <- Lp$both.idx[[2]]
  cluster.idx <- Lp$cluster.idx[[2]]

  # sanity checks
  if (any(diag(sigma.w) < 0) || any(diag(sigma.b) < 0)) {
    return(+Inf)
  }

  # check is both.idx part of sigma.b is 'too' negative; if so, return +Inf
  ev <- eigen(sigma.b[both.idx, both.idx, drop = FALSE],
    symmetric = TRUE,
    only.values = TRUE
  )$values
  if (any(ev < -0.05)) {
    return(+Inf)
  }

  # cat("sigma.w = \n"); print(sigma.w)
  # cat("sigma.b = \n"); print(sigma.b)
  # cat("mu.y = \n"); print(mu.y)

  # global
  sigma.w.inv <- solve.default(sigma.w)
  sigma.w.logdet <- log(det(sigma.w))
  sigma.b <- sigma.b[both.idx, both.idx] # only both part

  # y
  ny <- ncol(sigma.w)
  if (length(between.idx) > 0L) {
    Y1w <- Y1[, -between.idx, drop = FALSE]
  } else {
    Y1w <- Y1
  }
  Y1w.c <- t(t(Y1w) - mu.y)
  PIJ <- matrix(0, nrow(Y1w.c), ny)

  # z
  nz <- length(between.idx)
  if (nz > 0L) {
    # check is sigma.zz is PD; if not, return +Inf
    ev <- eigen(sigma.zz, symmetric = TRUE, only.values = TRUE)$values
    if (any(ev < sqrt(.Machine$double.eps))) {
      return(+Inf)
    }

    Z <- Y2[, between.idx, drop = FALSE]
    Z.c <- t(t(Z) - mu.z)

    sigma.yz <- sigma.yz[both.idx, , drop = FALSE] # only both part
    sigma.zy <- t(sigma.yz)
    sigma.zz.inv <- solve.default(sigma.zz)
    sigma.zz.logdet <- log(det(sigma.zz))
    sigma.zi.zy <- sigma.zz.inv %*% sigma.zy
    sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy
    GZ <- Z.c %*% sigma.zz.inv # for complete cases only
  }

  # containters per cluster
  q.yy.b <- q.zy <- q.zz.b <- numeric(nclusters)
  IBZA.j.logdet <- numeric(nclusters)
  ALIST <- rep(list(matrix(
    0, length(both.idx),
    length(both.idx)
  )), nclusters)

  # Z per missing pattern
  if (nz > 0L) {
    Zp <- Mp$Zp
    ZPAT2J <- integer(nclusters) # which sigma.b.z per cluster
    SIGMA.B.Z <- vector("list", length = Zp$npatterns + 1L)

    sigma.j.zz.logdet <- q.zz.a <- 0
    for (p in seq_len(Zp$npatterns)) {
      freq <- Zp$freq[p]
      z.na.idx <- which(!Zp$pat[p, ])
      j.idx <- Zp$case.idx[[p]] # cluster indices with this pattern
      ZPAT2J[j.idx] <- p

      if (length(z.na.idx) > 0L) {
        zp <- sigma.zz[-z.na.idx, -z.na.idx, drop = FALSE]
        zp.inv <- lav_matrix_symmetric_inverse_update(
          S.inv = sigma.zz.inv, rm.idx = z.na.idx,
          logdet = TRUE, S.logdet = sigma.zz.logdet
        )
        zp.logdet <- attr(zp.inv, "logdet")
        sigma.j.zz.logdet <- sigma.j.zz.logdet + (zp.logdet * freq)

        GZ[j.idx, -z.na.idx] <- Z.c[j.idx, -z.na.idx] %*% zp.inv

        yziy <- (sigma.yz[, -z.na.idx, drop = FALSE] %*% zp.inv %*%
          sigma.zy[-z.na.idx, , drop = FALSE])
        SIGMA.B.Z[[p]] <- (sigma.b - yziy)
      } else {
        # complete case
        sigma.j.zz.logdet <-
          sigma.j.zz.logdet + (sigma.zz.logdet * freq)
        SIGMA.B.Z[[p]] <- sigma.b.z
      }
    } # p

    # add empty patterns (if any)
    if (length(Zp$empty.idx) > 0L) {
      ZPAT2J[Zp$empty.idx] <- p + 1L
      SIGMA.B.Z[[p + 1L]] <- sigma.b
    }

    q.zz.a <- sum(GZ * Z.c, na.rm = TRUE)
    GZ0 <- GZ
    GZ0[is.na(GZ0)] <- 0
    GJ <- GZ0 %*% sigma.zy # only both part
  }

  # Y per missing pattern
  W.logdet <- 0
  #MPi <- integer(nrow(Y1))
  for (p in seq_len(Mp$npatterns)) {
    freq <- Mp$freq[p]
    na.idx <- which(!Mp$pat[p, ])
    j.idx <- Mp$j.idx[[p]]
    j1.idx <- Mp$j1.idx[[p]]
    TAB <- integer(nclusters)
    TAB[j1.idx] <- Mp$j.freq[[p]]

    # compute sigma.w.inv for this pattern
    if (length(na.idx) > 0L) {
      #MPi[Mp$case.idx[[p]]] <- p
      wp <- sigma.w[-na.idx, -na.idx, drop = FALSE]
      wp.inv <- lav_matrix_symmetric_inverse_update(
        S.inv = sigma.w.inv, rm.idx = na.idx,
        logdet = TRUE, S.logdet = sigma.w.logdet
      )
      wp.logdet <- attr(wp.inv, "logdet")
      W.logdet <- W.logdet + (wp.logdet * freq)

      PIJ[Mp$case.idx[[p]], -na.idx] <-
        Y1w.c[Mp$case.idx[[p]], -na.idx] %*% wp.inv

      A.j <- matrix(0, ny, ny)
      A.j[-na.idx, -na.idx] <- wp.inv
      for (j in j1.idx) {
        ALIST[[j]] <- ALIST[[j]] + (A.j[both.idx, both.idx] * TAB[j])
      }
      # WIP[[p]][-na.idx, -na.idx] <- wp.inv
    } else {
      # complete case
      W.logdet <- W.logdet + (sigma.w.logdet * freq)
      PIJ[Mp$case.idx[[p]], ] <-
        Y1w.c[Mp$case.idx[[p]], ] %*% sigma.w.inv
      for (j in j1.idx) {
        ALIST[[j]] <-
          ALIST[[j]] + (sigma.w.inv[both.idx, both.idx] * TAB[j])
      }
    }
  } # p
  q.yy.a <- sum(PIJ * Y1w.c, na.rm = TRUE)
  PJ <- rowsum.default(PIJ[, both.idx], cluster.idx,
    reorder = FALSE,
    na.rm = TRUE
  ) # only both part is needed

  # per cluster
  both.diag.idx <- lav_matrix_diag_idx(length(both.idx))
  for (j in seq_len(nclusters)) {
    # we only need the 'both.idx' part of A.j, sigma.b.z, p.j, g.j ,...
    A.j <- ALIST[[j]]
    p.j <- PJ[j, ]
    if (nz > 0L) {
      sigma.b.z <- SIGMA.B.Z[[ZPAT2J[j]]]
    } else {
      sigma.b.z <- sigma.b
    }
    IBZA.j <- sigma.b.z %*% A.j
    IBZA.j[both.diag.idx] <- IBZA.j[both.diag.idx] + 1
    # logdet IBZA.j
    tmp <- determinant.matrix(IBZA.j, logarithm = TRUE)
    IBZA.j.logdet[j] <- tmp$modulus * tmp$sign
    # IBZA.j.inv.BZ.p
    IBZA.j.inv.BZ.p <- solve.default(IBZA.j, drop(sigma.b.z %*% p.j))
    q.yy.b[j] <- sum(p.j * IBZA.j.inv.BZ.p)

    if (nz > 0L) {
      g.j <- GJ[j, ]
      IBZA.j.inv.g <- solve.default(IBZA.j, g.j)
      A.IBZA.j.inv.g <- A.j %*% IBZA.j.inv.g

      q.zz.b[j] <- sum(g.j * A.IBZA.j.inv.g)
      q.zy[j] <- -sum(p.j * IBZA.j.inv.g)
    }
  }


  if (nz > 0L) {
    P <- Mp$nel + Zp$nel
    DIST <- (q.yy.a - sum(q.yy.b)) + 2 * sum(q.zy) + (q.zz.a + sum(q.zz.b))
    LOGDET <- W.logdet + sum(IBZA.j.logdet) + sigma.j.zz.logdet
  } else {
    P <- Mp$nel
    DIST <- (q.yy.a - sum(q.yy.b))
    LOGDET <- W.logdet + sum(IBZA.j.logdet)
  }

  # loglik?
  if (log2pi && !minus.two) {
    LOG.2PI <- log(2 * pi)
    loglik <- -(P * LOG.2PI + LOGDET + DIST) / 2
  } else {
    loglik <- DIST + LOGDET
  }

  # loglik.x (only if loglik is requested)
  if (length(unlist(Lp$ov.x.idx)) > 0L && log2pi && !minus.two) {
    loglik <- loglik - loglik.x
  }

  loglik
}

# Mu.W, Mu.B, Sigma.W, Sigma.B are the model-implied statistics
lav_mvnorm_cluster_missing_dlogl_2l_samplestats <- function(
    Y1 = NULL,
    Y2 = NULL,
    Lp = NULL,
    Mp = NULL,
    Mu.W = NULL,
    Sigma.W = NULL,
    Mu.B = NULL,
    Sigma.B = NULL,
    Sinv.method = "eigen",
    return.list = FALSE) {
  # map implied to 2l matrices
  out <- lav_mvnorm_cluster_implied22l(
    Lp = Lp, Mu.W = Mu.W, Mu.B = Mu.B,
    Sigma.W = Sigma.W, Sigma.B = Sigma.B
  )
  mu.y <- out$mu.y
  mu.z <- out$mu.z
  sigma.w <- out$sigma.w
  sigma.b <- out$sigma.b
  sigma.zz <- out$sigma.zz
  sigma.yz <- out$sigma.yz

  # containers for dx
  dx.mu.y <- numeric(length(mu.y))
  dx.mu.z <- numeric(length(mu.z))
  dx.sigma.zz <- matrix(0, nrow(sigma.zz), ncol(sigma.zz))
  dx.sigma.yz <- matrix(0, nrow(sigma.yz), ncol(sigma.yz))
  dx.sigma.b <- matrix(0, nrow(sigma.b), ncol(sigma.b))
  dx.sigma.w <- matrix(0, nrow(sigma.w), ncol(sigma.w))

  # Lp
  nclusters <- Lp$nclusters[[2]]
  between.idx <- Lp$between.idx[[2]]
  cluster.idx <- Lp$cluster.idx[[2]]
  both.idx <- Lp$both.idx[[2]]

  # sigma.w
  sigma.w.inv <- solve.default(sigma.w)
  sigma.b <- sigma.b[both.idx, both.idx] # only both part

  # y
  ny <- ncol(sigma.w)
  if (length(between.idx) > 0L) {
    Y1w <- Y1[, -between.idx, drop = FALSE]
  } else {
    Y1w <- Y1
  }
  Y1w.c <- t(t(Y1w) - mu.y)
  PIJ <- matrix(0, nrow(Y1w.c), ny)

  # z
  nz <- length(between.idx)
  if (nz > 0L) {
    Z <- Y2[, between.idx, drop = FALSE]
    Z.c <- t(t(Z) - mu.z)
    sigma.yz <- sigma.yz[both.idx, , drop = FALSE] # only both part
    sigma.zy <- t(sigma.yz)
    sigma.zz.inv <- solve.default(sigma.zz)
    sigma.zz.logdet <- log(det(sigma.zz))
    sigma.zi.zy <- sigma.zz.inv %*% sigma.zy
    sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy
    GZ <- Z.c %*% sigma.zz.inv # for complete cases only
  }

  # containters per cluster
  # ALIST <- rep(list(matrix(0, length(both.idx),
  #                             length(both.idx))), nclusters)
  ALIST <- rep(list(matrix(0, ny, ny)), nclusters)

  # Z per missing pattern
  if (nz > 0L) {
    Zp <- Mp$Zp
    ZPAT2J <- integer(nclusters) # which pattern per cluster
    SIGMA.B.Z <- vector("list", length = Zp$npatterns + 1L) # +1 for empty
    ZIZY <- rep(list(matrix(
      0, nrow(sigma.zy),
      ncol(sigma.zy)
    )), Zp$npatterns + 1L)
    ZIP <- rep(list(matrix(
      0, nrow(sigma.zz),
      ncol(sigma.zz)
    )), Zp$npatterns + 1L)
    for (p in seq_len(Zp$npatterns)) {
      freq <- Zp$freq[p]
      z.na.idx <- which(!Zp$pat[p, ])
      j.idx <- Zp$case.idx[[p]] # cluster indices with this pattern
      ZPAT2J[j.idx] <- p

      if (length(z.na.idx) > 0L) {
        zp <- sigma.zz[-z.na.idx, -z.na.idx, drop = FALSE]
        zp.inv <- lav_matrix_symmetric_inverse_update(
          S.inv = sigma.zz.inv, rm.idx = z.na.idx,
          logdet = FALSE
        )
        ZIP[[p]][-z.na.idx, -z.na.idx] <- zp.inv
        GZ[j.idx, -z.na.idx] <- Z.c[j.idx, -z.na.idx] %*% zp.inv
        Z.G.ZY <- zp.inv %*% sigma.zy[-z.na.idx, , drop = FALSE]
        ZIZY[[p]][-z.na.idx, ] <-
          zp.inv %*% sigma.zy[-z.na.idx, , drop = FALSE]
        yziy <- sigma.yz[, -z.na.idx, drop = FALSE] %*% Z.G.ZY
        SIGMA.B.Z[[p]] <- (sigma.b - yziy)
      } else {
        # complete case
        ZIZY[[p]] <- sigma.zi.zy
        ZIP[[p]] <- sigma.zz.inv
        SIGMA.B.Z[[p]] <- sigma.b.z
      }
    } # p

    # add empty patterns (if any)
    if (length(Zp$empty.idx) > 0L) {
      ZPAT2J[Zp$empty.idx] <- p + 1L
      SIGMA.B.Z[[p + 1L]] <- sigma.b
    }

    GZ[is.na(GZ)] <- 0
    GJ <- GZ %*% sigma.zy
  }

  # Y per missing pattern
  WIP <- rep(list(matrix(0, ny, ny)), Mp$npatterns)
  MPi <- integer(nrow(Y1))
  for (p in seq_len(Mp$npatterns)) {
    freq <- Mp$freq[p]
    na.idx <- which(!Mp$pat[p, ])
    j.idx <- Mp$j.idx[[p]]
    j1.idx <- Mp$j1.idx[[p]]
    TAB <- integer(nclusters)
    TAB[j1.idx] <- Mp$j.freq[[p]]

    if (length(na.idx) > 0L) {
      MPi[Mp$case.idx[[p]]] <- p
      wp.inv <- lav_matrix_symmetric_inverse_update(
        S.inv = sigma.w.inv, rm.idx = na.idx,
        logdet = FALSE
      )
      WIP[[p]][-na.idx, -na.idx] <- wp.inv
      PIJ[Mp$case.idx[[p]], -na.idx] <-
        Y1w.c[Mp$case.idx[[p]], -na.idx] %*% wp.inv

      for (j in j1.idx) {
        ALIST[[j]] <-
          # ALIST[[j]] + (WIP[[p]][both.idx, both.idx] * TAB[j])
          ALIST[[j]] + (WIP[[p]] * TAB[j])
      }
    } else {
      # complete case
      PIJ[Mp$case.idx[[p]], ] <-
        Y1w.c[Mp$case.idx[[p]], ] %*% sigma.w.inv
      WIP[[p]] <- sigma.w.inv
      for (j in j1.idx) {
        ALIST[[j]] <-
          # ALIST[[j]] + (sigma.w.inv[both.idx, both.idx] * TAB[j])
          ALIST[[j]] + (sigma.w.inv * TAB[j])
      }
    }
  } # p
  PJ <- rowsum.default(PIJ[, , drop = FALSE],
    cluster.idx,
    reorder = FALSE, na.rm = TRUE
  )

  # per cluster
  both.diag.idx <- lav_matrix_diag_idx(length(both.idx))
  for (j in seq_len(nclusters)) {
    A.j.full <- ALIST[[j]]
    A.j <- A.j.full[both.idx, both.idx, drop = FALSE]
    p.j <- as.matrix(PJ[j, ])
    pb.j <- as.matrix(PJ[j, both.idx]) # only both.idx part
    if (nz > 0L) {
      sigma.b.z <- SIGMA.B.Z[[ZPAT2J[j]]]
    } else {
      sigma.b.z <- sigma.b
    }

    IBZA.j <- sigma.b.z %*% A.j
    IBZA.j[both.diag.idx] <- IBZA.j[both.diag.idx] + 1

    IBZA.j.inv.BZ <- solve.default(IBZA.j, sigma.b.z)
    IBZA.j.inv.BZ.p <- IBZA.j.inv.BZ %*% pb.j
    A.IBZA.j.inv.BZ <- A.j %*% IBZA.j.inv.BZ
    A.IBZA.j.inv.BZ.p <- A.IBZA.j.inv.BZ %*% pb.j

    IBZA.j.inv <- solve.default(IBZA.j)
    A.IBZA.j.inv <- A.j %*% IBZA.j.inv
    p.IBZA.j.inv <- t(crossprod(pb.j, IBZA.j.inv))

    # only if we have between-only variables
    if (nz > 0L) {
      g.j <- as.matrix(GJ[j, ])
      zij <- as.matrix(GZ[j, ])
      zizy <- ZIZY[[ZPAT2J[j]]]
      zip <- ZIP[[ZPAT2J[j]]]

      IBZA.j.inv.zizy <- solve.default(IBZA.j, t(zizy))
      IBZA.j.inv.g <- IBZA.j.inv %*% g.j
      IBZA.j.inv.p <- IBZA.j.inv %*% pb.j
      A.IBZA.j.inv.g <- A.j %*% IBZA.j.inv.g
      A.IBZA.j.inv.zizy <- A.j %*% IBZA.j.inv.zizy
      zizy.A.IBZA.j.inv.g <- zizy %*% A.IBZA.j.inv.g
      p.IBZA.j.inv.zizy <- crossprod(pb.j, IBZA.j.inv.zizy)
      ggbzpp <- 2 * A.IBZA.j.inv.g + A.IBZA.j.inv.BZ.p - pb.j
      ZIJzizyp <- (2 * zij - zizy %*% pb.j)

      ###########
      # dx.mu.z #
      ###########
      tmp <- 2 * (t(p.IBZA.j.inv.zizy) - zij - zizy.A.IBZA.j.inv.g)
      dx.mu.z <- dx.mu.z + drop(tmp)

      ###############
      # dx.sigma.zz #
      ###############
      tmp1 <- (zip + zizy %*% A.IBZA.j.inv.zizy # logdet
        - tcrossprod(zij) # ZA
        - tcrossprod(zizy.A.IBZA.j.inv.g)) # ZB-1

      d <- (t((2 * zizy.A.IBZA.j.inv.g + zizy %*% A.IBZA.j.inv.BZ.p)
      %*% p.IBZA.j.inv.zizy)
      + ZIJzizyp %*% p.IBZA.j.inv.zizy
        - 2 * tcrossprod(zizy.A.IBZA.j.inv.g, zij))
      tmp2 <- (d + t(d)) / 2
      tmp <- tmp1 + tmp2
      # symmetry correction
      ZZ <- 2 * tmp
      diag(ZZ) <- diag(tmp)
      dx.sigma.zz <- dx.sigma.zz + ZZ

      ###############
      # dx.sigma.yz #
      ###############
      t0 <- -2 * A.IBZA.j.inv.zizy

      t1 <- (-2 * tcrossprod(p.IBZA.j.inv, g.j)
        - 1 * tcrossprod(p.IBZA.j.inv, sigma.b.z %*% pb.j)
        + 2 * tcrossprod(A.IBZA.j.inv.g, g.j)) %*% A.IBZA.j.inv.zizy
      t2 <- -ggbzpp %*% p.IBZA.j.inv.zizy
      t3 <- -tcrossprod(p.IBZA.j.inv, ZIJzizyp)
      t4 <- 2 * tcrossprod(A.IBZA.j.inv.g, zij)
      tmp <- t0 + t1 + t2 + t3 + t4
      dx.sigma.yz[both.idx, ] <- dx.sigma.yz[both.idx, , drop = FALSE] + tmp

      ##############
      # dx.sigma.b #
      ##############
      c <- tcrossprod(ggbzpp, p.IBZA.j.inv)
      tmp <- t(A.IBZA.j.inv) - tcrossprod(A.IBZA.j.inv.g) + (c + t(c)) / 2
      # symmetry correction
      ZZ <- 2 * tmp
      diag(ZZ) <- diag(tmp)
      dx.sigma.b[both.idx, both.idx] <-
        dx.sigma.b[both.idx, both.idx, drop = FALSE] + ZZ

      # for dx.sigma.w
      PART1.b <- -1 * (IBZA.j.inv.g %*%
        (2 * t(IBZA.j.inv.BZ.p) + t(g.j) -
          t(g.j) %*% A.IBZA.j.inv.BZ)
        + IBZA.j.inv.BZ + tcrossprod(IBZA.j.inv.BZ.p))
      PART2.b <- 2 * (IBZA.j.inv.g + IBZA.j.inv.BZ.p) # vector
    } else {
      ##############
      # dx.sigma.b #
      ##############
      bzpp <- A.IBZA.j.inv.BZ.p - pb.j
      c <- tcrossprod(bzpp, p.IBZA.j.inv)
      tmp <- t(A.IBZA.j.inv) + (c + t(c)) / 2
      # symmetry correction
      ZZ <- 2 * tmp
      diag(ZZ) <- diag(tmp)
      dx.sigma.b[both.idx, both.idx] <-
        dx.sigma.b[both.idx, both.idx, drop = FALSE] + ZZ

      PART1.b <- -1 * (IBZA.j.inv.BZ + tcrossprod(IBZA.j.inv.BZ.p))
      PART2.b <- 2 * IBZA.j.inv.BZ.p # vector
    }

    ##############
    # dx.sigma.w #
    ##############

    PART1 <- matrix(0, ny, ny)
    PART1[both.idx, both.idx] <- PART1.b

    PART2 <- matrix(0, ny, 1L)
    PART2[both.idx, 1L] <- PART2.b

    ij.index <- which(cluster.idx == j)
    pij <- PIJ[ij.index, , drop = FALSE]

    which.compl <- which(MPi[ij.index] == 0L)
    which.incompl <- which(MPi[ij.index] != 0L)

    AP2 <- rep(list(sigma.w.inv %*% PART2), length(ij.index))
    AP1A.a <- AP1A.b <- matrix(0, ny, ny)
    # A.j.full <- matrix(0, ny, ny)
    if (length(which.compl) > 0L) {
      tmp <- (sigma.w.inv %*% PART1 %*% sigma.w.inv)
      AP1A.a <- tmp * length(which.compl)
      # A.j.full <- A.j.full + sigma.w.inv * length(which.compl)
    }
    if (length(which.incompl) > 0L) {
      p.idx <- MPi[ij.index][which.incompl]
      tmp <- lapply(WIP[p.idx], function(x) {
        x %*% PART1 %*% x
      })
      AP1A.b <- Reduce("+", tmp)
      AP2[which.incompl] <-
        lapply(WIP[p.idx], function(x) {
          x %*% PART2
        })
      # A.j.full <- A.j.full + Reduce("+", WIP[ p.idx ])
    }
    t1 <- AP1A.a + AP1A.b
    t2 <- (do.call("cbind", AP2) - t(pij)) %*% pij

    AA.wj <- t1 + t2

    tmp <- A.j.full + (AA.wj + t(AA.wj)) / 2
    # symmetry correction
    ZZ <- 2 * tmp
    diag(ZZ) <- diag(tmp)
    dx.sigma.w <- dx.sigma.w + ZZ

    ###########
    # dx.mu.y #
    ###########
    tmp <- numeric(ny)
    if (nz > 0L) {
      tmp[both.idx] <- IBZA.j.inv.g + IBZA.j.inv.BZ.p
    } else {
      tmp[both.idx] <- IBZA.j.inv.BZ.p
    }
    gbzpp <- A.j.full %*% tmp - p.j
    dx.mu.y <- dx.mu.y + drop(2 * gbzpp)
  } # j

  # rearrange
  dout <- lav_mvnorm_cluster_2l2implied(
    Lp = Lp,
    sigma.w = dx.sigma.w, sigma.b = dx.sigma.b,
    sigma.yz = dx.sigma.yz, sigma.zz = dx.sigma.zz,
    mu.y = dx.mu.y, mu.z = dx.mu.z
  )

  if (return.list) {
    out <- dout
  } else {
    out <- c(
      dout$Mu.W, lav_matrix_vech(dout$Sigma.W),
      dout$Mu.B, lav_matrix_vech(dout$Sigma.B)
    )
  }

  out
}

# cluster-wise scores -2*logl wrt Mu.W, Mu.B, Sigma.W, Sigma.B
lav_mvnorm_cluster_missing_scores_2l <- function(
    Y1 = NULL,
    Y2 = NULL,
    Lp = NULL,
    Mp = NULL,
    Mu.W = NULL,
    Sigma.W = NULL,
    Mu.B = NULL,
    Sigma.B = NULL,
    Sinv.method = "eigen") {
  # map implied to 2l matrices
  out <- lav_mvnorm_cluster_implied22l(
    Lp = Lp, Mu.W = Mu.W, Mu.B = Mu.B,
    Sigma.W = Sigma.W, Sigma.B = Sigma.B
  )
  mu.y <- out$mu.y
  mu.z <- out$mu.z
  sigma.w <- out$sigma.w
  sigma.b <- out$sigma.b
  sigma.zz <- out$sigma.zz
  sigma.yz <- out$sigma.yz

  # Lp
  nclusters <- Lp$nclusters[[2]]
  between.idx <- Lp$between.idx[[2]]
  cluster.idx <- Lp$cluster.idx[[2]]
  both.idx <- Lp$both.idx[[2]]

  # sigma.w
  sigma.w.inv <- solve.default(sigma.w)
  sigma.b <- sigma.b[both.idx, both.idx] # only both part

  # y
  ny <- ncol(sigma.w)
  if (length(between.idx) > 0L) {
    Y1w <- Y1[, -between.idx, drop = FALSE]
  } else {
    Y1w <- Y1
  }
  Y1w.c <- t(t(Y1w) - mu.y)
  PIJ <- matrix(0, nrow(Y1w.c), ny)

  # z
  nz <- length(between.idx)
  if (nz > 0L) {
    Z <- Y2[, between.idx, drop = FALSE]
    Z.c <- t(t(Z) - mu.z)
    sigma.yz <- sigma.yz[both.idx, , drop = FALSE] # only both part
    sigma.zy <- t(sigma.yz)
    sigma.zz.inv <- solve.default(sigma.zz)
    sigma.zz.logdet <- log(det(sigma.zz))
    sigma.zi.zy <- sigma.zz.inv %*% sigma.zy
    sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy
    GZ <- Z.c %*% sigma.zz.inv # for complete cases only
  }

  # containters per cluster
  # ALIST <- rep(list(matrix(0, length(both.idx),
  #                             length(both.idx))), nclusters)
  ALIST <- rep(list(matrix(0, ny, ny)), nclusters)

  # both level-1 and level-2
  G.muy <- matrix(0, nclusters, length(mu.y))
  G.Sigma.w <- matrix(0, nclusters, length(lav_matrix_vech(sigma.w)))
  G.Sigma.b <- matrix(0, nclusters, length(lav_matrix_vech(out$sigma.b)))
  G.muz <- matrix(0, nclusters, length(mu.z))
  G.Sigma.zz <- matrix(0, nclusters, length(lav_matrix_vech(sigma.zz)))
  G.Sigma.yz <- matrix(0, nclusters, length(lav_matrix_vec(out$sigma.yz)))

  # Z per missing pattern
  if (nz > 0L) {
    Zp <- Mp$Zp
    ZPAT2J <- integer(nclusters) # which pattern per cluster
    SIGMA.B.Z <- vector("list", length = Zp$npatterns + 1L) # +1 for empty
    ZIZY <- rep(list(matrix(
      0, nrow(sigma.zy),
      ncol(sigma.zy)
    )), Zp$npatterns + 1L)
    ZIP <- rep(list(matrix(
      0, nrow(sigma.zz),
      ncol(sigma.zz)
    )), Zp$npatterns + 1L)
    for (p in seq_len(Zp$npatterns)) {
      freq <- Zp$freq[p]
      z.na.idx <- which(!Zp$pat[p, ])
      j.idx <- Zp$case.idx[[p]] # cluster indices with this pattern
      ZPAT2J[j.idx] <- p

      if (length(z.na.idx) > 0L) {
        zp <- sigma.zz[-z.na.idx, -z.na.idx, drop = FALSE]
        zp.inv <- lav_matrix_symmetric_inverse_update(
          S.inv = sigma.zz.inv, rm.idx = z.na.idx,
          logdet = FALSE
        )
        ZIP[[p]][-z.na.idx, -z.na.idx] <- zp.inv
        GZ[j.idx, -z.na.idx] <- Z.c[j.idx, -z.na.idx] %*% zp.inv
        Z.G.ZY <- zp.inv %*% sigma.zy[-z.na.idx, , drop = FALSE]
        ZIZY[[p]][-z.na.idx, ] <-
          zp.inv %*% sigma.zy[-z.na.idx, , drop = FALSE]
        yziy <- sigma.yz[, -z.na.idx, drop = FALSE] %*% Z.G.ZY
        SIGMA.B.Z[[p]] <- (sigma.b - yziy)
      } else {
        # complete case
        ZIZY[[p]] <- sigma.zi.zy
        ZIP[[p]] <- sigma.zz.inv
        SIGMA.B.Z[[p]] <- sigma.b.z
      }
    } # p

    # add empty patterns (if any)
    if (length(Zp$empty.idx) > 0L) {
      ZPAT2J[Zp$empty.idx] <- p + 1L
      SIGMA.B.Z[[p + 1L]] <- sigma.b
    }

    GZ[is.na(GZ)] <- 0
    GJ <- GZ %*% sigma.zy
  }

  # Y per missing pattern
  WIP <- rep(list(matrix(0, ny, ny)), Mp$npatterns)
  MPi <- integer(nrow(Y1))
  for (p in seq_len(Mp$npatterns)) {
    freq <- Mp$freq[p]
    na.idx <- which(!Mp$pat[p, ])
    j.idx <- Mp$j.idx[[p]]
    j1.idx <- Mp$j1.idx[[p]]
    TAB <- integer(nclusters)
    TAB[j1.idx] <- Mp$j.freq[[p]]

    if (length(na.idx) > 0L) {
      MPi[Mp$case.idx[[p]]] <- p
      wp.inv <- lav_matrix_symmetric_inverse_update(
        S.inv = sigma.w.inv, rm.idx = na.idx,
        logdet = FALSE
      )
      WIP[[p]][-na.idx, -na.idx] <- wp.inv
      PIJ[Mp$case.idx[[p]], -na.idx] <-
        Y1w.c[Mp$case.idx[[p]], -na.idx] %*% wp.inv

      for (j in j1.idx) {
        ALIST[[j]] <-
          # ALIST[[j]] + (WIP[[p]][both.idx, both.idx] * TAB[j])
          ALIST[[j]] + (WIP[[p]] * TAB[j])
      }
    } else {
      # complete case
      PIJ[Mp$case.idx[[p]], ] <-
        Y1w.c[Mp$case.idx[[p]], ] %*% sigma.w.inv
      WIP[[p]] <- sigma.w.inv
      for (j in j1.idx) {
        ALIST[[j]] <-
          # ALIST[[j]] + (sigma.w.inv[both.idx, both.idx] * TAB[j])
          ALIST[[j]] + (sigma.w.inv * TAB[j])
      }
    }
  } # p

  PJ <- rowsum.default(PIJ[, , drop = FALSE],
    cluster.idx,
    reorder = FALSE, na.rm = TRUE
  )

  # per cluster
  both.diag.idx <- lav_matrix_diag_idx(length(both.idx))
  for (j in seq_len(nclusters)) {
    A.j.full <- ALIST[[j]]
    A.j <- A.j.full[both.idx, both.idx, drop = FALSE]
    p.j <- as.matrix(PJ[j, ])
    pb.j <- as.matrix(PJ[j, both.idx]) # only both.idx part
    if (nz > 0L) {
      sigma.b.z <- SIGMA.B.Z[[ZPAT2J[j]]]
    } else {
      sigma.b.z <- sigma.b
    }

    IBZA.j <- sigma.b.z %*% A.j
    IBZA.j[both.diag.idx] <- IBZA.j[both.diag.idx] + 1

    IBZA.j.inv.BZ <- solve.default(IBZA.j, sigma.b.z)
    IBZA.j.inv.BZ.p <- IBZA.j.inv.BZ %*% pb.j
    A.IBZA.j.inv.BZ <- A.j %*% IBZA.j.inv.BZ
    A.IBZA.j.inv.BZ.p <- A.IBZA.j.inv.BZ %*% pb.j

    IBZA.j.inv <- solve.default(IBZA.j)
    A.IBZA.j.inv <- A.j %*% IBZA.j.inv
    p.IBZA.j.inv <- t(crossprod(pb.j, IBZA.j.inv))

    # only if we have between-only variables
    if (nz > 0L) {
      g.j <- as.matrix(GJ[j, ])
      zij <- as.matrix(GZ[j, ])
      zizy <- ZIZY[[ZPAT2J[j]]]
      zip <- ZIP[[ZPAT2J[j]]]

      IBZA.j.inv.zizy <- solve.default(IBZA.j, t(zizy))
      IBZA.j.inv.g <- IBZA.j.inv %*% g.j
      IBZA.j.inv.p <- IBZA.j.inv %*% pb.j
      A.IBZA.j.inv.g <- A.j %*% IBZA.j.inv.g
      A.IBZA.j.inv.zizy <- A.j %*% IBZA.j.inv.zizy
      zizy.A.IBZA.j.inv.g <- zizy %*% A.IBZA.j.inv.g
      p.IBZA.j.inv.zizy <- crossprod(pb.j, IBZA.j.inv.zizy)
      ggbzpp <- 2 * A.IBZA.j.inv.g + A.IBZA.j.inv.BZ.p - pb.j
      ZIJzizyp <- (2 * zij - zizy %*% pb.j)

      ###########
      # dx.mu.z #
      ###########
      tmp <- 2 * (t(p.IBZA.j.inv.zizy) - zij - zizy.A.IBZA.j.inv.g)
      G.muz[j, ] <- drop(tmp)

      ###############
      # dx.sigma.zz #
      ###############
      tmp1 <- (zip + zizy %*% A.IBZA.j.inv.zizy # logdet
        - tcrossprod(zij) # ZA
        - tcrossprod(zizy.A.IBZA.j.inv.g)) # ZB-1

      d <- (t((2 * zizy.A.IBZA.j.inv.g + zizy %*% A.IBZA.j.inv.BZ.p)
      %*% p.IBZA.j.inv.zizy)
      + ZIJzizyp %*% p.IBZA.j.inv.zizy
        - 2 * tcrossprod(zizy.A.IBZA.j.inv.g, zij))
      tmp2 <- (d + t(d)) / 2
      tmp <- tmp1 + tmp2
      # symmetry correction
      ZZ <- 2 * tmp
      diag(ZZ) <- diag(tmp)
      G.Sigma.zz[j, ] <- lav_matrix_vech(ZZ)

      ###############
      # dx.sigma.yz #
      ###############
      t0 <- -2 * A.IBZA.j.inv.zizy

      t1 <- (-2 * tcrossprod(p.IBZA.j.inv, g.j)
        - 1 * tcrossprod(p.IBZA.j.inv, sigma.b.z %*% pb.j)
        + 2 * tcrossprod(A.IBZA.j.inv.g, g.j)) %*% A.IBZA.j.inv.zizy
      t2 <- -ggbzpp %*% p.IBZA.j.inv.zizy
      t3 <- -tcrossprod(p.IBZA.j.inv, ZIJzizyp)
      t4 <- 2 * tcrossprod(A.IBZA.j.inv.g, zij)
      tmp <- t0 + t1 + t2 + t3 + t4
      tmp2 <- matrix(0, nrow(out$sigma.yz), ncol(out$sigma.yz))
      tmp2[both.idx, ] <- tmp
      G.Sigma.yz[j, ] <- lav_matrix_vec(tmp2)

      ##############
      # dx.sigma.b #
      ##############
      c <- tcrossprod(ggbzpp, p.IBZA.j.inv)
      tmp <- t(A.IBZA.j.inv) - tcrossprod(A.IBZA.j.inv.g) + (c + t(c)) / 2
      # symmetry correction
      ZZ <- 2 * tmp
      diag(ZZ) <- diag(tmp)
      ZZ2 <- matrix(0, nrow(out$sigma.b), ncol(out$sigma.b))
      ZZ2[both.idx, both.idx] <- ZZ
      G.Sigma.b[j, ] <- lav_matrix_vech(ZZ2)
      # dx.sigma.b[both.idx, both.idx] <-
      #  dx.sigma.b[both.idx, both.idx, drop = FALSE] + ZZ

      # for dx.sigma.w
      PART1.b <- -1 * (IBZA.j.inv.g %*%
        (2 * t(IBZA.j.inv.BZ.p) + t(g.j) -
          t(g.j) %*% A.IBZA.j.inv.BZ)
        + IBZA.j.inv.BZ + tcrossprod(IBZA.j.inv.BZ.p))
      PART2.b <- 2 * (IBZA.j.inv.g + IBZA.j.inv.BZ.p) # vector
    } else {
      ##############
      # dx.sigma.b #
      ##############
      bzpp <- A.IBZA.j.inv.BZ.p - pb.j
      c <- tcrossprod(bzpp, p.IBZA.j.inv)
      tmp <- t(A.IBZA.j.inv) + (c + t(c)) / 2
      # symmetry correction
      ZZ <- 2 * tmp
      diag(ZZ) <- diag(tmp)
      ZZ2 <- matrix(0, nrow(out$sigma.b), ncol(out$sigma.b))
      ZZ2[both.idx, both.idx] <- ZZ
      G.Sigma.b[j, ] <- lav_matrix_vech(ZZ2)
      # dx.sigma.b[both.idx, both.idx] <-
      #  dx.sigma.b[both.idx, both.idx, drop = FALSE] + ZZ

      PART1.b <- -1 * (IBZA.j.inv.BZ + tcrossprod(IBZA.j.inv.BZ.p))
      PART2.b <- 2 * IBZA.j.inv.BZ.p # vector
    }

    ##############
    # dx.sigma.w #
    ##############

    PART1 <- matrix(0, ny, ny)
    PART1[both.idx, both.idx] <- PART1.b

    PART2 <- matrix(0, ny, 1L)
    PART2[both.idx, 1L] <- PART2.b

    ij.index <- which(cluster.idx == j)
    pij <- PIJ[ij.index, , drop = FALSE]

    which.compl <- which(MPi[ij.index] == 0L)
    which.incompl <- which(MPi[ij.index] != 0L)

    AP2 <- rep(list(sigma.w.inv %*% PART2), length(ij.index))
    AP1A.a <- AP1A.b <- matrix(0, ny, ny)
    # A.j.full <- matrix(0, ny, ny)
    if (length(which.compl) > 0L) {
      tmp <- (sigma.w.inv %*% PART1 %*% sigma.w.inv)
      AP1A.a <- tmp * length(which.compl)
      # A.j.full <- A.j.full + sigma.w.inv * length(which.compl)
    }
    if (length(which.incompl) > 0L) {
      p.idx <- MPi[ij.index][which.incompl]
      tmp <- lapply(WIP[p.idx], function(x) {
        x %*% PART1 %*% x
      })
      AP1A.b <- Reduce("+", tmp)
      AP2[which.incompl] <-
        lapply(WIP[p.idx], function(x) {
          x %*% PART2
        })
      # A.j.full <- A.j.full + Reduce("+", WIP[ p.idx ])
    }
    t1 <- AP1A.a + AP1A.b
    t2 <- (do.call("cbind", AP2) - t(pij)) %*% pij

    AA.wj <- t1 + t2

    tmp <- A.j.full + (AA.wj + t(AA.wj)) / 2
    # symmetry correction
    ZZ <- 2 * tmp
    diag(ZZ) <- diag(tmp)
    G.Sigma.w[j, ] <- lav_matrix_vech(ZZ)
    # dx.sigma.w <- dx.sigma.w + ZZ

    ###########
    # dx.mu.y #
    ###########
    tmp <- numeric(ny)
    if (nz > 0L) {
      tmp[both.idx] <- IBZA.j.inv.g + IBZA.j.inv.BZ.p
    } else {
      tmp[both.idx] <- IBZA.j.inv.BZ.p
    }
    gbzpp <- A.j.full %*% tmp - p.j
    # dx.mu.y <- dx.mu.y + drop(2 * gbzpp)
    G.muy[j, ] <- drop(2 * gbzpp)
  } # j

  # browser()

  # rearrange columns to Mu.W, Mu.B, Sigma.W, Sigma.B
  ov.idx <- Lp$ov.idx
  p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]])))

  # Mu.W (for within-only)
  Mu.W.tilde <- matrix(0, nclusters, p.tilde)
  Mu.W.tilde[, ov.idx[[1]]] <- G.muy
  Mu.W.tilde[, Lp$both.idx[[2]]] <- 0 # ZERO!!!
  Mu.W <- Mu.W.tilde[, ov.idx[[1]], drop = FALSE]

  # Mu.B
  Mu.B.tilde <- matrix(0, nclusters, p.tilde)
  Mu.B.tilde[, ov.idx[[1]]] <- G.muy
  if (length(between.idx) > 0L) {
    Mu.B.tilde[, between.idx] <- G.muz
  }
  Mu.B <- Mu.B.tilde[, ov.idx[[2]], drop = FALSE]

  # Sigma.W
  Sigma.W <- G.Sigma.w

  # Sigma.B
  if (length(between.idx) > 0L) {
    p.tilde.star <- p.tilde * (p.tilde + 1) / 2
    B.tilde <- lav_matrix_vech_reverse(seq_len(p.tilde.star))

    Sigma.B.tilde <- matrix(0, nclusters, p.tilde.star)

    col.idx <- lav_matrix_vech(B.tilde[ov.idx[[1]], ov.idx[[1]],
      drop = FALSE
    ])
    Sigma.B.tilde[, col.idx] <- G.Sigma.b

    col.idx <- lav_matrix_vec(B.tilde[ov.idx[[1]], between.idx,
      drop = FALSE
    ])
    Sigma.B.tilde[, col.idx] <- G.Sigma.yz

    col.idx <- lav_matrix_vech(B.tilde[between.idx, between.idx,
      drop = FALSE
    ])
    Sigma.B.tilde[, col.idx] <- G.Sigma.zz

    col.idx <- lav_matrix_vech(B.tilde[ov.idx[[2]], ov.idx[[2]],
      drop = FALSE
    ])
    Sigma.B <- Sigma.B.tilde[, col.idx, drop = FALSE]
  } else {
    p.tilde.star <- p.tilde * (p.tilde + 1) / 2
    B.tilde <- lav_matrix_vech_reverse(seq_len(p.tilde.star))

    Sigma.B.tilde <- matrix(0, nclusters, p.tilde.star)

    col.idx <- lav_matrix_vech(B.tilde[ov.idx[[1]], ov.idx[[1]],
      drop = FALSE
    ])
    Sigma.B.tilde[, col.idx] <- G.Sigma.b

    col.idx <- lav_matrix_vech(B.tilde[ov.idx[[2]], ov.idx[[2]],
      drop = FALSE
    ])
    Sigma.B <- Sigma.B.tilde[, col.idx, drop = FALSE]
    # Sigma.B <- G.Sigma.b
  }

  SCORES <- cbind(Mu.W, Sigma.W, Mu.B, Sigma.B)

  SCORES
}

# first-order information: outer crossprod of scores per cluster
lav_mvnorm_cluster_missing_information_firstorder <- function(
    Y1 = NULL,
    Y2 = NULL,
    Lp = NULL,
    Mp = NULL,
    Mu.W = NULL,
    Sigma.W = NULL,
    Mu.B = NULL,
    Sigma.B = NULL,
    x.idx = NULL,
    divide.by.two = FALSE,
    Sinv.method = "eigen") {
  N <- NROW(Y1)

  SCORES <- lav_mvnorm_cluster_missing_scores_2l(
    Y1 = Y1,
    Y2 = Y2,
    Lp = Lp,
    Mp = Mp,
    Mu.W = Mu.W,
    Sigma.W = Sigma.W,
    Mu.B = Mu.B,
    Sigma.B = Sigma.B,
    Sinv.method = Sinv.method
  )

  # divide by 2 (if we want scores wrt objective function)
  if (divide.by.two) {
    SCORES <- SCORES / 2
  }

  # unit information
  information <- crossprod(SCORES) / Lp$nclusters[[2]]


  # if x.idx, set rows/cols to zero
  if (length(x.idx) > 0L) {
    nw <- length(as.vector(Mu.W))
    nw.star <- nw * (nw + 1) / 2
    nb <- length(as.vector(Mu.B))
    ov.idx <- Lp$ov.idx

    x.idx.w <- which(ov.idx[[1]] %in% x.idx)
    if (length(x.idx.w) > 0L) {
      xw.idx <- c(
        x.idx.w,
        nw + lav_matrix_vech_which_idx(n = nw, idx = x.idx.w)
      )
    } else {
      xw.idx <- integer(0L)
    }
    x.idx.b <- which(ov.idx[[2]] %in% x.idx)
    if (length(x.idx.b) > 0L) {
      xb.idx <- c(
        x.idx.b,
        nb + lav_matrix_vech_which_idx(n = nb, idx = x.idx.b)
      )
    } else {
      xb.idx <- integer(0L)
    }

    all.idx <- c(xw.idx, nw + nw.star + xb.idx)

    information[all.idx, ] <- 0
    information[, all.idx] <- 0
  }

  information
}

# observed information
# order: mu.w within, vech(sigma.w) within, mu.b between, vech(sigma.b) between
# mu.w rows/cols that are splitted within/between are forced to zero
#
# numerical approximation (for now)
lav_mvnorm_cluster_missing_information_observed <- function(
    Y1 = NULL,
    Y2 = NULL,
    Lp = NULL,
    Mp = NULL,
    YLp = NULL,
    Mu.W = NULL,
    Sigma.W = NULL,
    Mu.B = NULL,
    Sigma.B = NULL,
    x.idx = integer(0L),
    Sinv.method = "eigen") {

  nobs <- Lp$nclusters[[1]]

  nw <- length(as.vector(Mu.W))
  nw.star <- nw * (nw + 1) / 2
  nb <- length(as.vector(Mu.B))
  nb.star <- nb * (nb + 1) / 2

  ov.idx <- Lp$ov.idx
  p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]])))

  # Mu.W (for within-only)
  Mu.W.tilde <- numeric(p.tilde)
  Mu.W.tilde[ov.idx[[1]]] <- Mu.W

  # local function -- gradient
  GRAD <- function(x) {
    # Mu.W (for within-only)
    Mu.W.tilde2 <- numeric(p.tilde)
    Mu.W.tilde2[ov.idx[[1]]] <- x[1:nw]
    Mu.W.tilde2[Lp$both.idx[[2]]] <- Mu.W.tilde[Lp$both.idx[[2]]]
    Mu.W2 <- Mu.W.tilde2[ov.idx[[1]]]

    Sigma.W2 <- lav_matrix_vech_reverse(x[nw + 1:nw.star])
    Mu.B2 <- x[nw + nw.star + 1:nb]
    Sigma.B2 <- lav_matrix_vech_reverse(x[nw + nw.star + nb + 1:nb.star])

    dx <- lav_mvnorm_cluster_missing_dlogl_2l_samplestats(
      Y1 = Y1, Y2 = Y2, Lp = Lp, Mp = Mp,
      Mu.W = Mu.W2, Sigma.W = Sigma.W2,
      Mu.B = Mu.B2, Sigma.B = Sigma.B2,
      return.list = FALSE,
      Sinv.method = Sinv.method
    )

    # dx is for -2*logl
    -1 / 2 * dx
  }

  # start.x
  start.x <- c(
    as.vector(Mu.W), lav_matrix_vech(Sigma.W),
    as.vector(Mu.B), lav_matrix_vech(Sigma.B)
  )

  # total information
  information <- -1 * numDeriv::jacobian(func = GRAD, x = start.x)

  # unit information
  information <- information / Lp$nclusters[[2]]


  # if x.idx, set rows/cols to zero
  if (length(x.idx) > 0L) {
    x.idx.w <- which(ov.idx[[1]] %in% x.idx)
    if (length(x.idx.w) > 0L) {
      xw.idx <- c(
        x.idx.w,
        nw + lav_matrix_vech_which_idx(n = nw, idx = x.idx.w)
      )
    } else {
      xw.idx <- integer(0L)
    }
    x.idx.b <- which(ov.idx[[2]] %in% x.idx)
    if (length(x.idx.b) > 0L) {
      xb.idx <- c(
        x.idx.b,
        nb + lav_matrix_vech_which_idx(n = nb, idx = x.idx.b)
      )
    } else {
      xb.idx <- integer(0L)
    }

    all.idx <- c(xw.idx, nw + nw.star + xb.idx)

    information[all.idx, ] <- 0
    information[, all.idx] <- 0
  }

  information
}

# the multivariate linear model using maximum likelihood

# 1) loglikelihood (from raw data, or sample statistics)
# 2) derivatives with respect to Beta, res.cov, vech(res.cov)
# 3) casewise scores with respect to Beta, vech(res.cov), Beta + vech(res.cov)
# 4) hessian Beta + vech(res.cov)
# 5) information h0 Beta + vech(res.cov)
#    5a: (unit)    expected information
#    5b: (unit)    observed information
#    5c: (unit) first.order information

# YR 24 Mar 2016: first version
# YR 20 Jan 2017: removed added 'N' in many equations, to be consistent with
#                 lav_mvnorm_*
# YR 18 Okt 2018: add 'information' functions, change arguments
#                 (X -> eXo, Sigma -> res.cov, Beta -> res.int + res.slopes)

# 1. loglikelihood

# 1a. input is raw data
lav_mvreg_loglik_data <- function(Y = NULL,
                                  eXo = NULL, # no intercept
                                  Beta = NULL,
                                  res.int = NULL,
                                  res.slopes = NULL,
                                  res.cov = NULL,
                                  casewise = FALSE,
                                  Sinv.method = "eigen") {
  Y <- unname(Y)
  Q <- NCOL(Y)
  N <- NROW(Y)
  X <- cbind(1, unname(eXo))

  # construct model-implied Beta
  if (is.null(Beta)) {
    Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
  }

  if (casewise) {
    LOG.2PI <- log(2 * pi)

    # invert res.cov
    if (Sinv.method == "chol") {
      cS <- chol(res.cov)
      icS <- backsolve(cS, diag(Q))
      logdet <- -2 * sum(log(diag(icS)))

      RES <- Y - X %*% Beta
      DIST <- rowSums((RES %*% icS)^2)
    } else {
      res.cov.inv <- lav_matrix_symmetric_inverse(
        S = res.cov, logdet = TRUE,
        Sinv.method = Sinv.method
      )
      logdet <- attr(res.cov.inv, "logdet")

      RES <- Y - X %*% Beta
      DIST <- rowSums(RES %*% res.cov.inv * RES)
    }

    loglik <- -(Q * LOG.2PI + logdet + DIST) / 2
  } else {
    # invert res.cov
    res.cov.inv <- lav_matrix_symmetric_inverse(
      S = res.cov, logdet = TRUE,
      Sinv.method = Sinv.method
    )
    logdet <- attr(res.cov.inv, "logdet")

    RES <- Y - X %*% Beta
    # TOTAL <- TR( (Y - X%*%Beta) %*% res.cov.inv %*% t(Y - X%*%Beta) )
    TOTAL <- sum(rowSums(RES %*% res.cov.inv * RES))
    loglik <- -(N * Q / 2) * log(2 * pi) - (N / 2) * logdet - (1 / 2) * TOTAL
  }

  loglik
}


# 2b. input are sample statistics (res.int, res.slopes, res.cov, N) only
lav_mvreg_loglik_samplestats <- function(sample.res.int = NULL,
                                         sample.res.slopes = NULL,
                                         sample.res.cov = NULL,
                                         sample.mean.x = NULL,
                                         sample.cov.x = NULL,
                                         sample.nobs = NULL,
                                         Beta = NULL, # optional
                                         res.int = NULL,
                                         res.slopes = NULL,
                                         res.cov = NULL,
                                         Sinv.method = "eigen",
                                         res.cov.inv = NULL) {
  Q <- NCOL(sample.res.cov)
  N <- sample.nobs
  LOG.2PI <- log(2 * pi)

  # construct model-implied Beta
  if (is.null(Beta)) {
    Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
  }

  # construct 'saturated' (sample-based) B
  sample.B <- rbind(matrix(sample.res.int, nrow = 1), t(sample.res.slopes))

  # construct sample.xx = 1/N*crossprod(X1) (including intercept)
  sample.xx <- rbind(
    cbind(1, matrix(sample.mean.x, nrow = 1, )),
    cbind(
      matrix(sample.mean.x, ncol = 1),
      sample.cov.x + tcrossprod(sample.mean.x)
    )
  )

  # res.cov.inv
  if (is.null(res.cov.inv)) {
    res.cov.inv <- lav_matrix_symmetric_inverse(
      S = res.cov, logdet = TRUE,
      Sinv.method = Sinv.method
    )
    logdet <- attr(res.cov.inv, "logdet")
  } else {
    logdet <- attr(res.cov.inv, "logdet")
    if (is.null(logdet)) {
      # compute - ln|res.cov.inv|
      ev <- eigen(res.cov.inv, symmetric = TRUE, only.values = TRUE)
      logdet <- -1 * sum(log(ev$values))
    }
  }

  # tr(res.cov^{-1} %*% S)
  DIST1 <- sum(res.cov.inv * sample.res.cov)

  # tr( res.cov^{-1} (B-beta)' X'X (B-beta)
  Diff <- sample.B - Beta
  DIST2 <- sum(res.cov.inv * crossprod(Diff, sample.xx) %*% Diff)

  loglik <- -(N / 2) * (Q * log(2 * pi) + logdet + DIST1 + DIST2)

  loglik
}




# 2. Derivatives

# 2a. derivative logl with respect to Beta (=intercepts and slopes)
lav_mvreg_dlogl_dbeta <- function(Y = NULL,
                                  eXo = NULL,
                                  Beta = NULL,
                                  res.int = NULL,
                                  res.slopes = NULL,
                                  res.cov = NULL,
                                  Sinv.method = "eigen",
                                  res.cov.inv = NULL) {
  Y <- unname(Y)
  X <- cbind(1, unname(eXo))

  # construct model-implied Beta
  if (is.null(Beta)) {
    Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
  }

  # res.cov.inv
  if (is.null(res.cov.inv)) {
    # invert res.cov
    res.cov.inv <- lav_matrix_symmetric_inverse(
      S = res.cov, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # substract 'X %*% Beta' from Y
  RES <- Y - X %*% Beta

  # derivative
  dbeta <- as.numeric(t(X) %*% RES %*% res.cov.inv)

  dbeta
}

# 2b: derivative logl with respect to res.cov (full matrix, ignoring symmetry)
lav_mvreg_dlogl_drescov <- function(Y = NULL,
                                    eXo = NULL,
                                    Beta = NULL,
                                    res.cov = NULL,
                                    res.int = NULL,
                                    res.slopes = NULL,
                                    Sinv.method = "eigen",
                                    res.cov.inv = NULL) {
  Y <- unname(Y)
  N <- NROW(Y)
  X <- cbind(1, unname(eXo))

  # construct model-implied Beta
  if (is.null(Beta)) {
    Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
  }

  # res.cov.in
  if (is.null(res.cov.inv)) {
    # invert res.cov
    res.cov.inv <- lav_matrix_symmetric_inverse(
      S = res.cov, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # substract 'X %*% Beta' from Y
  RES <- Y - X %*% Beta

  # W.tilde
  W.tilde <- crossprod(RES) / N

  # derivative
  dres.cov <- -(N / 2) * (res.cov.inv - (res.cov.inv %*% W.tilde %*% res.cov.inv))

  dres.cov
}

# 2c: derivative logl with respect to vech(res.cov)
lav_mvreg_dlogl_dvechrescov <- function(Y = NULL,
                                        eXo = NULL,
                                        Beta = NULL,
                                        res.int = NULL,
                                        res.slopes = NULL,
                                        res.cov = NULL,
                                        Sinv.method = "eigen",
                                        res.cov.inv = NULL) {
  Y <- unname(Y)
  N <- NROW(Y)
  X <- cbind(1, unname(eXo))

  # construct model-implied Beta
  if (is.null(Beta)) {
    Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
  }

  # res.cov.inv
  if (is.null(res.cov.inv)) {
    # invert res.cov
    res.cov.inv <- lav_matrix_symmetric_inverse(
      S = res.cov, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # substract 'X %*% Beta' from Y
  RES <- Y - X %*% Beta

  # W.tilde
  W.tilde <- crossprod(RES) / N

  # derivative
  dres.cov <- -(N / 2) * (res.cov.inv - (res.cov.inv %*% W.tilde %*% res.cov.inv))
  dvechres.cov <- as.numeric(lav_matrix_duplication_pre(
    as.matrix(lav_matrix_vec(dres.cov))
  ))

  dvechres.cov
}


# 3. Casewise scores

# 3a: casewise scores with respect to Beta (=intercepts and slopes)
#     column order: Y1_int, Y1_x1, Y1_x2, ...| Y2_int, Y2_x1, Y2_x2, ... |
lav_mvreg_scores_beta <- function(Y = NULL,
                                  eXo = NULL,
                                  Beta = NULL,
                                  res.int = NULL,
                                  res.slopes = NULL,
                                  res.cov = NULL,
                                  Sinv.method = "eigen",
                                  res.cov.inv = NULL) {
  Y <- unname(Y)
  Q <- NCOL(Y)
  X <- cbind(1, unname(eXo))
  P <- NCOL(X)

  # construct model-implied Beta
  if (is.null(Beta)) {
    Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
  }

  # res.cov.inv
  if (is.null(res.cov.inv)) {
    # invert res.cov
    res.cov.inv <- lav_matrix_symmetric_inverse(
      S = res.cov, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # substract Mu
  RES <- Y - X %*% Beta

  # post-multiply with res.cov.inv
  RES <- RES %*% res.cov.inv

  SC.Beta <- X[, rep(1:P, times = Q), drop = FALSE] *
    RES[, rep(1:Q, each = P), drop = FALSE]

  SC.Beta
}


# 3b: casewise scores with respect to vech(res.cov)
lav_mvreg_scores_vech_sigma <- function(Y = NULL,
                                        eXo = NULL,
                                        Beta = NULL,
                                        res.int = NULL,
                                        res.slopes = NULL,
                                        res.cov = NULL,
                                        Sinv.method = "eigen",
                                        res.cov.inv = NULL) {
  Y <- unname(Y)
  Q <- NCOL(Y)
  X <- cbind(1, unname(eXo))

  # construct model-implied Beta
  if (is.null(Beta)) {
    Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
  }

  # res.cov.inv
  if (is.null(res.cov.inv)) {
    # invert res.cov
    res.cov.inv <- lav_matrix_symmetric_inverse(
      S = res.cov, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # vech(res.cov.inv)
  isigma <- lav_matrix_vech(res.cov.inv)

  # substract X %*% Beta
  RES <- Y - X %*% Beta

  # postmultiply with res.cov.inv
  RES <- RES %*% res.cov.inv

  # tcrossprod
  idx1 <- lav_matrix_vech_col_idx(Q)
  idx2 <- lav_matrix_vech_row_idx(Q)
  Z <- RES[, idx1] * RES[, idx2]

  # substract isigma from each row
  SC <- t(t(Z) - isigma)

  # adjust for vech (and avoiding the 1/2 factor)
  SC[, lav_matrix_diagh_idx(Q)] <- SC[, lav_matrix_diagh_idx(Q)] / 2

  SC
}


# 3c: casewise scores with respect to beta + vech(res.cov)
lav_mvreg_scores_beta_vech_sigma <- function(Y = NULL,
                                             eXo = NULL,
                                             Beta = NULL,
                                             res.int = NULL,
                                             res.slopes = NULL,
                                             res.cov = NULL,
                                             Sinv.method = "eigen",
                                             res.cov.inv = NULL) {
  Y <- unname(Y)
  Q <- NCOL(Y)
  X <- cbind(1, unname(eXo))
  P <- NCOL(X)

  # construct model-implied Beta
  if (is.null(Beta)) {
    Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
  }

  # res.cov.inv
  if (is.null(res.cov.inv)) {
    # invert res.cov
    res.cov.inv <- lav_matrix_symmetric_inverse(
      S = res.cov, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # vech(res.cov.inv)
  isigma <- lav_matrix_vech(res.cov.inv)

  # substract X %*% Beta
  RES <- Y - X %*% Beta

  # postmultiply with res.cov.inv
  RES <- RES %*% res.cov.inv

  SC.Beta <- X[, rep(1:P, times = Q), drop = FALSE] *
    RES[, rep(1:Q, each = P), drop = FALSE]

  # tcrossprod
  idx1 <- lav_matrix_vech_col_idx(Q)
  idx2 <- lav_matrix_vech_row_idx(Q)
  Z <- RES[, idx1] * RES[, idx2]

  # substract isigma from each row
  SC <- t(t(Z) - isigma)

  # adjust for vech (and avoiding the 1/2 factor)
  SC[, lav_matrix_diagh_idx(Q)] <- SC[, lav_matrix_diagh_idx(Q)] / 2

  cbind(SC.Beta, SC)
}

# 4. hessian of logl

# 4a. hessian logl Beta and vech(res.cov) from raw data
lav_mvreg_logl_hessian_data <- function(Y = NULL,
                                        eXo = NULL, # no int
                                        Beta = NULL, # int+slopes
                                        res.int = NULL,
                                        res.slopes = NULL,
                                        res.cov = NULL,
                                        res.cov.inv = NULL,
                                        Sinv.method = "eigen") {
  # sample size
  N <- NROW(Y)

  # observed information
  observed <- lav_mvreg_information_observed_data(
    Y = Y, eXo = eXo,
    Beta = Beta, res.int = res.int, res.slopes = res.slopes,
    res.cov = res.cov, res.cov.inv = res.cov.inv,
    Sinv.method = Sinv.method
  )

  # hessian
  -N * observed
}

# 4b. hessian logl Beta and vech(res.cov) from samplestats
lav_mvreg_logl_hessian_samplestats <- function(sample.res.int = NULL,
                                               sample.res.slopes = NULL,
                                               sample.res.cov = NULL,
                                               sample.mean.x = NULL,
                                               sample.cov.x = NULL,
                                               sample.nobs = NULL,
                                               Beta = NULL, # int + slopes
                                               res.int = NULL, # intercepts only
                                               res.slopes = NULL, # slopes only (y x x)
                                               res.cov = NULL, # res.cov
                                               Sinv.method = "eigen",
                                               res.cov.inv = NULL) {
  # sample size
  N <- sample.nobs

  # information
  observed <- lav_mvreg_information_observed_samplestats(
    sample.res.int = sample.res.int, sample.res.slopes = sample.res.slopes,
    sample.res.cov = sample.res.cov, sample.mean.x = sample.mean.x,
    sample.cov.x = sample.cov.x, Beta = Beta, res.int = res.int,
    res.slopes = res.slopes, res.cov = res.cov, Sinv.method = Sinv.method,
    res.cov.inv = res.cov.inv
  )

  # hessian
  -N * observed
}


# Information h0

# 5a: unit expected information h0 Beta and vech(res.cov)
lav_mvreg_information_expected <- function(Y = NULL, # not used
                                           eXo = NULL, # not used
                                           sample.mean.x = NULL,
                                           sample.cov.x = NULL,
                                           sample.nobs = NULL,
                                           Beta = NULL, # not used
                                           res.int = NULL, # not used
                                           res.slopes = NULL, # not used
                                           res.cov = NULL,
                                           res.cov.inv = NULL,
                                           Sinv.method = "eigen") {
  eXo <- unname(eXo)

  # res.cov.inv
  if (is.null(res.cov.inv)) {
    # invert res.cov
    res.cov.inv <- lav_matrix_symmetric_inverse(
      S = res.cov, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # N
  if (is.null(sample.nobs)) {
    sample.nobs <- nrow(eXo) # hopefully not NULL either
  } else {
    N <- sample.nobs
  }

  # sample.mean.x + sample.cov.x
  if (is.null(sample.mean.x)) {
    sample.mean.x <- base::.colMeans(eXo, m = NROW(eXo), n = NCOL(eXo))
  }
  if (is.null(sample.cov.x)) {
    sample.cov.x <- lav_matrix_cov(eXo)
  }

  # construct sample.xx = 1/N*crossprod(X1) (including intercept)
  sample.xx <- rbind(
    cbind(1, matrix(sample.mean.x, nrow = 1, )),
    cbind(
      matrix(sample.mean.x, ncol = 1),
      sample.cov.x + tcrossprod(sample.mean.x)
    )
  )

  # expected information
  I11 <- res.cov.inv %x% sample.xx
  # if (lav_use_lavaanC()) {
  #   I22 <- lavaanC::m_kronecker_dup_pre_post(res.cov.inv, multiplicator = 0.5)
  # } else {
    I22 <- 0.5 * lav_matrix_duplication_pre_post(res.cov.inv %x% res.cov.inv)
  # }

  lav_matrix_bdiag(I11, I22)
}

# 5b: unit observed information h0
lav_mvreg_information_observed_data <- function(Y = NULL,
                                                eXo = NULL, # no int
                                                Beta = NULL, # int+slopes
                                                res.int = NULL,
                                                res.slopes = NULL,
                                                res.cov = NULL,
                                                res.cov.inv = NULL,
                                                Sinv.method = "eigen") {
  # create sample statistics
  Y <- unname(Y)
  X1 <- cbind(1, unname(eXo))
  N <- NROW(Y)

  # find 'B'
  QR <- qr(X1)
  sample.B <- qr.coef(QR, Y)

  sample.res.int <- as.numeric(sample.B[1, ])
  sample.res.slopes <- t(sample.B[-1, , drop = FALSE]) # transpose!
  sample.res.cov <- cov(qr.resid(QR, Y)) * (N - 1) / N
  sample.mean.x <- base::.colMeans(eXo, m = NROW(eXo), n = NCOL(eXo))
  sample.cov.x <- lav_matrix_cov(eXo)

  lav_mvreg_information_observed_samplestats(
    sample.res.int = sample.res.int,
    sample.res.slopes = sample.res.slopes, sample.res.cov = sample.res.cov,
    sample.mean.x = sample.mean.x, sample.cov.x = sample.cov.x,
    Beta = Beta, res.int = res.int, res.slopes = res.slopes,
    res.cov = res.cov, Sinv.method = Sinv.method, res.cov.inv = res.cov.inv
  )
}


# 5b-bis: observed information h0 from sample statistics
lav_mvreg_information_observed_samplestats <-
  function(sample.res.int = NULL,
           sample.res.slopes = NULL,
           sample.res.cov = NULL,
           sample.mean.x = NULL,
           sample.cov.x = NULL,
           Beta = NULL, # int + slopes
           res.int = NULL, # intercepts only
           res.slopes = NULL, # slopes only (y x x)
           res.cov = NULL, # res.cov
           Sinv.method = "eigen",
           res.cov.inv = NULL) {
    # construct model-implied Beta
    if (is.null(Beta)) {
      Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
    }

    # construct 'saturated' (sample-based) B
    sample.B <- rbind(matrix(sample.res.int, nrow = 1), t(sample.res.slopes))

    # construct sample.xx = 1/N*crossprod(X1) (including intercept)
    sample.xx <- rbind(
      cbind(1, matrix(sample.mean.x, nrow = 1, )),
      cbind(
        matrix(sample.mean.x, ncol = 1),
        sample.cov.x + tcrossprod(sample.mean.x)
      )
    )

    # W.tilde = S + t(B - Beta) %*% (1/N)*X'X %*% (B - Beta)
    W.tilde <- (sample.res.cov +
      t(sample.B - Beta) %*% sample.xx %*% (sample.B - Beta))

    # res.cov.inv
    if (is.null(res.cov.inv)) {
      # invert res.cov
      res.cov.inv <- lav_matrix_symmetric_inverse(
        S = res.cov, logdet = FALSE,
        Sinv.method = Sinv.method
      )
    }

    H11 <- res.cov.inv %x% sample.xx
    H21 <- lav_matrix_duplication_pre(res.cov.inv %x%
      (res.cov.inv %*% (crossprod(sample.B - Beta, sample.xx))))
    H12 <- t(H21)

    AAA <- res.cov.inv %*% (2 * W.tilde - res.cov) %*% res.cov.inv
    # if (lav_use_lavaanC()) {
    #   H22 <- lavaanC::m_kronecker_dup_pre_post(res.cov.inv, AAA, 0.5)
    # } else {
      H22 <- (1 / 2) * lav_matrix_duplication_pre_post(res.cov.inv %x% AAA)
    # }

    out <- rbind(
      cbind(H11, H12),
      cbind(H21, H22)
    )
    out
  }


# 5c: unit first-order information h0
lav_mvreg_information_firstorder <- function(Y = NULL,
                                             eXo = NULL, # no int
                                             Beta = NULL, # int+slopes
                                             res.int = NULL,
                                             res.slopes = NULL,
                                             res.cov = NULL,
                                             res.cov.inv = NULL,
                                             Sinv.method = "eigen") {
  N <- NROW(Y)

  # scores
  SC <- lav_mvreg_scores_beta_vech_sigma(
    Y = Y, eXo = eXo, Beta = Beta,
    res.int = res.int, res.slopes = res.slopes, res.cov = res.cov,
    Sinv.method = Sinv.method, res.cov.inv = res.cov.inv
  )

  crossprod(SC) / N
}


# 6: inverted information h0

# 6a: inverted unit expected information h0 Beta and vech(res.cov)
#
# lav_mvreg_inverted_information_expected <- function(Y       = NULL, # unused!
# }

# `methods' for fitted lavaan objects
#
# standard (S4) methods:
# - show()
# - summary()
# - coef()
# - fitted.values() + fitted()
# - vcov()
# - logLik()
# - nobs()
# - update()
# - anova()

# lavaan-specific methods:
#
# - lavParameterEstimates()
# - standardizedSolution()
# - parameterTable()
# - varTable()


setMethod(
  "show", "lavaan",
  function(object) {
    # efa?
    efa.flag <- object@Options$model.type == "efa"

    # show only basic information
    res <- lav_object_summary(object,
      fit.measures = FALSE,
      estimates = FALSE,
      modindices = FALSE,
      efa = efa.flag
    )
    if (efa.flag) {
      # print (standardized) loadings only
      class(res) <- c("lavaan.efa", "list")
      print(res)
    } else {
      # print lavaan header
      print(res)
    }
    invisible(res)
  }
)

setMethod(
  "summary", "lavaan",
  function(object, header = TRUE,
           fit.measures = FALSE,
           estimates = TRUE,
           ci = FALSE,
           fmi = FALSE,
           standardized = FALSE,
           std = standardized,
           std.nox = FALSE, # TODO: remove deprecated argument in early 2025
           remove.system.eq = TRUE,
           remove.eq = TRUE,
           remove.ineq = TRUE,
           remove.def = FALSE,
           remove.nonfree = FALSE,
           remove.step1 = TRUE,
           remove.unused = TRUE,
           plabel = FALSE,
           cov.std = TRUE,
           rsquare = FALSE,
           baseline.model = NULL,
           h1.model = NULL,
           fm.args = list(
             standard.test = "default",
             scaled.test = "default",
             rmsea.ci.level = 0.90,
             rmsea.h0.closefit = 0.05,
             rmsea.h0.notclosefit = 0.08,
             robust = TRUE,
             cat.check.pd = TRUE
           ),
           modindices = FALSE,
           srmr.close.h0 = NULL,
           nd = 3L, cutoff = 0.3, dot.cutoff = 0.1, ...) {
    dotdotdot <- list(...)
    if (length(dotdotdot) > 0L) {
      for (j in seq_along(dotdotdot)) {
        lav_msg_warn(gettextf(
          "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
          sQuote("summary"))
        )
      }
    }
    # efa?
    efa.flag <- object@Options$model.type == "efa"

    if (is.logical(fit.measures)) {
      if (fit.measures) {
        fit.measures <- "default"
      } else {
        fit.measures <- "none"
      }
    }
    if (!is.list(fit.measures)) fit.measures <- list(fit.measures = fit.measures)
    if (!missing(fm.args)) {
      lav_deprecated_args("fit.measures", "fm.args")
      fit.measures <- c(fit.measures, fm.args)
    }
    res <- lav_object_summary(
      object = object, header = header,
      fit.measures = fit.measures, estimates = estimates,
      baseline.model = baseline.model,
      h1.model = h1.model,
      ci = ci, fmi = fmi, std = std, standardized = standardized,
      remove.system.eq = remove.system.eq,
      remove.eq = remove.eq, remove.ineq = remove.ineq,
      remove.def = remove.def, remove.nonfree = remove.nonfree,
      remove.step1 = remove.step1, remove.unused = remove.unused,
      plabel = plabel, cov.std = cov.std,
      rsquare = rsquare, efa = efa.flag,
      modindices = modindices,
      srmr.close.h0 = srmr.close.h0
    )
    # res has class c("lavaan.summary", "list")

    # what about nd? only used if we actually print; save as attribute
    attr(res, "nd") <- nd

    # if efa, add cutoff and dot.cutoff, and change class
    if (efa.flag) {
      # class(res) <- c("lavaan.summary.efa", "list")
      attr(res, "cutoff") <- cutoff
      attr(res, "dot.cutoff") <- dot.cutoff
    }

    res
  }
)


setMethod(
  "coef", "lavaan",
  function(object, type = "free", labels = TRUE, ...) {
    dotdotdot <- list(...)
    if (length(dotdotdot) > 0L) {
      for (j in seq_along(dotdotdot)) {
        lav_msg_warn(gettextf(
          "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
            sQuote("coef"))
        )
      }
    }
    # check object
    object <- lav_object_check_version(object)

    lav_object_inspect_coef(
      object = object, type = type,
      add.labels = labels, add.class = TRUE
    )
  }
)

standardizedSolution <- # nolint
  standardizedsolution <- function(object, # nolint
                                   type = "std.all",
                                   se = TRUE,
                                   zstat = TRUE,
                                   pvalue = TRUE,
                                   ci = TRUE,
                                   level = 0.95,
                                   cov.std = TRUE,
                                   remove.eq = TRUE,
                                   remove.ineq = TRUE,
                                   remove.def = FALSE,
                                   partable = NULL,
                                   GLIST = NULL, # nolint
                                   est = NULL,
                                   output = "data.frame") {

    # check object
    object <- lav_object_check_version(object)

    # check type
    stopifnot(type %in% c("std.all", "std.lv", "std.nox"))

    # check output= argument
    output <- tolower(output)
    if (output %in% c("data.frame", "table")) {
      output <- "data.frame"
    } else if (output %in% c("text", "pretty")) {
      output <- "text"
    } else {
      lav_msg_stop(gettextf(
        "output must be %s or %s", sQuote("data.frame"), sQuote("text"))
      )
    }

    # no zstat + pvalue if estimator is Bayes
    if (object@Options$estimator == "Bayes") {
      zstat <- pvalue <- FALSE
    }

    # no se if class is not lavaan
    # using class() -- can't use inherits(), as this includes blavaan
    if (class(object)[1L] != "lavaan") {
      if (missing(se) || !se) {
        se <- FALSE
        zstat <- FALSE
        pvalue <- FALSE
      }
    }

    if (is.null(partable)) {
      tmp.partable <- lavInspect(object, "list")
    } else {
      tmp.partable <- partable
    }
    tmp.list <- tmp.partable[, c("lhs", "op", "rhs", "exo")]
    if (!is.null(tmp.partable$group)) {
      tmp.list$group <- tmp.partable$group
    }
    if (!is.null(tmp.partable$block)) {
      tmp.list$block <- tmp.partable$block
    }
    if (sum(nchar(tmp.partable$label)) != 0L) {
      tmp.list$label <- tmp.partable$label
    }

    # add std and std.all columns
    if (type == "std.lv") {
      tmp.list$est.std <- lav_standardize_lv(object,
        est = est, GLIST = GLIST,
        partable = partable, cov.std = cov.std
      )
    } else if (type == "std.all") {
      tmp.list$est.std <- lav_standardize_all(object,
        est = est, GLIST = GLIST,
        partable = partable, cov.std = cov.std
      )
    } else if (type == "std.nox") {
      tmp.list$est.std <- lav_standardize_all_nox(object,
        est = est, GLIST = GLIST,
        partable = partable, cov.std = cov.std
      )
    }

    if (object@Options$se != "none" && se) {
      # add 'se' for standardized parameters
      tmp.vcov <- try(lav_object_inspect_vcov(object,
        standardized = TRUE,
        type = type, free.only = FALSE,
        add.labels = FALSE,
        add.class = FALSE
      ))
      if (inherits(tmp.vcov, "try-error") || is.null(tmp.vcov)) {
        tmp.list$se <- rep(NA, length(tmp.list$lhs))
        if (zstat) {
          tmp.list$z <- rep(NA, length(tmp.list$lhs))
        }
        if (pvalue) {
          tmp.list$pvalue <- rep(NA, length(tmp.list$lhs))
        }
      } else {
        tmp <- diag(tmp.vcov)
        # catch negative values
        min.idx <- which(tmp < 0)
        if (length(min.idx) > 0L) {
          tmp[min.idx] <- as.numeric(NA)
        }
        # now, we can safely take the square root
        tmp <- sqrt(tmp)

        # catch near-zero SEs
        zero.idx <- which(tmp < .Machine$double.eps^(1 / 4)) # was 1/2 < 0.6
        # was 1/3 < 0.6-9
        if (length(zero.idx) > 0L) {
          tmp[zero.idx] <- 0.0
        }
        tmp.list$se <- tmp

        # add 'z' column
        if (zstat) {
          tmp.se <- ifelse(tmp.list$se == 0.0, NA, tmp.list$se)
          tmp.list$z <- tmp.list$est.std / tmp.se
        }
        if (zstat && pvalue) {
          tmp.list$pvalue <- 2 * (1 - pnorm(abs(tmp.list$z)))
        }
      }
    }

    # simple symmetric confidence interval
    if (se && object@Options$se != "none" && ci) {
      # next three lines based on confint.lm
      a <- (1 - level) / 2
      a <- c(a, 1 - a)
      fac <- qnorm(a)
      # if(object@Options$se != "bootstrap") {
      ci <- tmp.list$est.std + tmp.list$se %o% fac
      # } else {
      #    ci <- rep(as.numeric(NA), length(tmp.list$est.std)) +
      #              tmp.list$se %o% fac
      # }

      tmp.list$ci.lower <- ci[, 1]
      tmp.list$ci.upper <- ci[, 2]
    }


    # if single group, remove group column
    if (object@Data@ngroups == 1L) tmp.list$group <- NULL

    # remove == rows?
    if (remove.eq) {
      eq.idx <- which(tmp.list$op == "==")
      if (length(eq.idx) > 0L) {
        tmp.list <- tmp.list[-eq.idx, ]
      }
    }
    # remove <> rows?
    if (remove.ineq) {
      ineq.idx <- which(tmp.list$op %in% c("<", ">"))
      if (length(ineq.idx) > 0L) {
        tmp.list <- tmp.list[-ineq.idx, ]
      }
    }
    # remove := rows?
    if (remove.def) {
      def.idx <- which(tmp.list$op == ":=")
      if (length(def.idx) > 0L) {
        tmp.list <- tmp.list[-def.idx, ]
      }
    }

    # remove attribute for data order
    attr(tmp.list, "ovda") <- NULL

    if (output == "text") {
      class(tmp.list) <- c(
        "lavaan.parameterEstimates", "lavaan.data.frame",
        "data.frame"
      )
      # tmp.list$exo is needed for printing, don't remove it
      attr(tmp.list, "group.label") <- object@Data@group.label
      attr(tmp.list, "level.label") <- object@Data@level.label
      # attr(tmp.list, "header") <- FALSE
    } else {
      tmp.list$exo <- NULL
      tmp.list$block <- NULL
      class(tmp.list) <- c("lavaan.data.frame", "data.frame")
    }

    tmp.list
  }

lavParameterEstimates <- function(object,                 # nolint
                                 # select columns
                                 se = TRUE,
                                 zstat = TRUE,
                                 pvalue = TRUE,
                                 ci = TRUE,
                                 standardized = FALSE,
                                 fmi = FALSE,
                                 plabel = FALSE,
                                 # control
                                 level = 0.95,
                                 boot.ci.type = "perc",
                                 cov.std = TRUE,
                                 fmi.options = list(),
                                 # add rows
                                 rsquare = FALSE,
                                 # remove rows
                                 remove.system.eq = TRUE,
                                 remove.eq = TRUE,
                                 remove.ineq = TRUE,
                                 remove.def = FALSE,
                                 remove.nonfree = FALSE,
                                 remove.step1 = TRUE,
                                 remove.unused = FALSE,
                                 # output
                                 add.attributes = FALSE,
                                 output = "data.frame",
                                 header = FALSE) {

    # lavaan.fsr?
    if (inherits(object, "lavaan.fsr")) {
      return(object$PE)
    }

    # check object
    object <- lav_object_check_version(object)

    # deprecated add.attributes (for psycho/blavaan)
    if (add.attributes) {
      output <- "text"
    }


    # no se if class is not lavaan
    # can't use inherits(), as this would return TRUE if object is from blavaan
    if (class(object)[1L] != "lavaan") {
      if (missing(se) || !se) {
        se <- FALSE
        zstat <- FALSE
        pvalue <- FALSE
      }
    }

    # check output= argument
    output <- tolower(output)
    if (output %in% c("data.frame", "table")) {
      output <- "data.frame"
      header <- FALSE
    } else if (output %in% c("text", "pretty")) {
      output <- "text"
    } else {
      lav_msg_stop(gettextf(
        "output must be %s or %s", sQuote("data.frame"), sQuote("text"))
      )
    }

    # check fmi
    if (fmi) {
      if (inherits(object, "lavaanList")) {
        lav_msg_warn(gettext(
          "fmi not available for object of class \"lavaanList\""))
        fmi <- FALSE
      }
      if (object@Options$se != "standard") {
        lav_msg_warn(gettext(
          "fmi only available if se = \"standard\""))
        fmi <- FALSE
      }
      if (object@Options$estimator != "ML") {
        lav_msg_warn(gettext(
          "fmi only available if estimator = \"ML\""))
        fmi <- FALSE
      }
      if (!object@SampleStats@missing.flag) {
        lav_msg_warn(gettext(
          "fmi only available if missing = \"(fi)ml\""))
        fmi <- FALSE
      }
      if (!object@optim$converged) {
        lav_msg_warn(gettext(
          "fmi not available; model did not converge"))
        fmi <- FALSE
      }
    }

    # no zstat + pvalue if estimator is Bayes
    if (object@Options$estimator == "Bayes") {
      zstat <- pvalue <- FALSE
    }

    tmp.partable <- as.data.frame(object@ParTable, stringsAsFactors = FALSE)
    tmp.list <- tmp.partable[, c("lhs", "op", "rhs", "free")]
    if (!is.null(tmp.partable$user)) {
      tmp.list$user <- tmp.partable$user
    }
    if (!is.null(tmp.partable$block)) {
      tmp.list$block <- tmp.partable$block
    } else {
      tmp.list$block <- rep(1L, length(tmp.list$lhs))
    }
    if (!is.null(tmp.partable$level)) {
      tmp.list$level <- tmp.partable$level
    } else {
      tmp.list$level <- rep(1L, length(tmp.list$lhs))
    }
    if (!is.null(tmp.partable$group)) {
      tmp.list$group <- tmp.partable$group
    } else {
      tmp.list$group <- rep(1L, length(tmp.list$lhs))
    }
    if (!is.null(tmp.partable$step)) {
      tmp.list$step <- tmp.partable$step
    }
    if (!is.null(tmp.partable$efa)) {
      tmp.list$efa <- tmp.partable$efa
    }
    if (!is.null(tmp.partable$label)) {
      tmp.list$label <- tmp.partable$label
    } else {
      tmp.list$label <- rep("", length(tmp.list$lhs))
    }
    if (!is.null(tmp.partable$exo)) {
      tmp.list$exo <- tmp.partable$exo
    } else {
      tmp.list$exo <- rep(0L, length(tmp.list$lhs))
    }
    if (inherits(object, "lavaanList")) {
      # per default: nothing!
      # if("partable" %in% object@meta$store.slots) {
      #    COF <- sapply(object@ParTableList, "[[", "est")
      #    tmp.list$est <- rowMeans(COF)
      # }
      tmp.list$est <- NULL
    } else if (!is.null(tmp.partable$est)) {
      tmp.list$est <- tmp.partable$est
    } else {
      tmp.list$est <- lav_model_get_parameters(object@Model,
        type = "user",
        extra = TRUE
      )
    }
    if (!is.null(tmp.partable$lower)) {
      tmp.list$lower <- tmp.partable$lower
    }
    if (!is.null(tmp.partable$upper)) {
      tmp.list$upper <- tmp.partable$upper
    }


    # add se, zstat, pvalue
    if (se && object@Options$se != "none") {
      tmp.list$se <- lav_object_inspect_se(object)
      # handle tiny SEs
      tmp.list$se <- ifelse(tmp.list$se < sqrt(.Machine$double.eps),
        0, tmp.list$se
      )
      tmp.se <- ifelse(tmp.list$se < sqrt(.Machine$double.eps), NA, tmp.list$se)
      if (zstat) {
        tmp.list$z <- tmp.list$est / tmp.se
        if (pvalue) {
          tmp.list$pvalue <- 2 * (1 - pnorm(abs(tmp.list$z)))
          # remove p-value if bounds have been used
          if (!is.null(tmp.partable$lower)) {
            b.idx <- which(abs(tmp.partable$lower - tmp.partable$est) <
              sqrt(.Machine$double.eps) &
              tmp.partable$free > 0L)
            if (length(b.idx) > 0L) {
              tmp.list$pvalue[b.idx] <- as.numeric(NA)
            }
          }
          if (!is.null(tmp.partable$upper)) {
            b.idx <- which(abs(tmp.partable$upper - tmp.partable$est) <
              sqrt(.Machine$double.eps) &
              tmp.partable$free > 0L)
            if (length(b.idx) > 0L) {
              tmp.list$pvalue[b.idx] <- as.numeric(NA)
            }
          }
        }
      }
    }

    # extract bootstrap data (if any)
    if (object@Options$se == "bootstrap" ||
      "bootstrap" %in% object@Options$test ||
      "bollen.stine" %in% object@Options$test) {
      tmp.boot <- lav_object_inspect_boot(object)
      bootstrap.seed <- attr(tmp.boot, "seed") # for bca
      error.idx <- attr(tmp.boot, "error.idx")
      if (length(error.idx) > 0L) {
        tmp.boot <- tmp.boot[-error.idx, , drop = FALSE] # drops attributes
      }
    } else {
      tmp.boot <- NULL
    }

    bootstrap.successful <- NROW(tmp.boot) # should be zero if NULL

    # confidence interval
    if (se && object@Options$se != "none" && ci) {
      # next three lines based on confint.lm
      a <- (1 - level) / 2
      a <- c(a, 1 - a)
      if (object@Options$se != "bootstrap") {
        fac <- qnorm(a)
        ci <- tmp.list$est + tmp.list$se %o% fac
      } else if (object@Options$se == "bootstrap") {
        # local copy of 'norm.inter' from boot package (not exported!)
        norm.inter <- function(t, alpha) {
          t <- t[is.finite(t)]
          tmp.r <- length(t)
          rk <- (tmp.r + 1) * alpha
          if (!all(rk > 1 & rk < tmp.r)) {
            lav_msg_warn(gettext("extreme order statistics used as endpoints"))
          }
          k <- trunc(rk)
          inds <- seq_along(k)
          out <- inds
          kvs <- k[k > 0 & k < tmp.r]
          tstar <- sort(t, partial = sort(union(c(1, tmp.r), c(kvs, kvs + 1))))
          ints <- (k == rk)
          if (any(ints)) out[inds[ints]] <- tstar[k[inds[ints]]]
          out[k == 0] <- tstar[1L]
          out[k == tmp.r] <- tstar[tmp.r]
          not <- function(v) xor(rep(TRUE, length(v)), v)
          temp <- inds[not(ints) & k != 0 & k != tmp.r]
          temp1 <- qnorm(alpha[temp])
          temp2 <- qnorm(k[temp] / (tmp.r + 1))
          temp3 <- qnorm((k[temp] + 1) / (tmp.r + 1))
          tk <- tstar[k[temp]]
          tk1 <- tstar[k[temp] + 1L]
          out[temp] <- tk + (temp1 - temp2) / (temp3 - temp2) * (tk1 - tk)
          cbind(round(rk, 2), out)
        }

        stopifnot(!is.null(tmp.boot))
        stopifnot(boot.ci.type %in% c(
          "norm", "basic", "perc",
          "bca.simple", "bca"
        ))
        if (boot.ci.type == "norm") {
          fac <- qnorm(a)
          boot.x <- colMeans(tmp.boot, na.rm = TRUE)
          boot.est <-
            lav_model_get_parameters(object@Model,
              GLIST = lav_model_x2glist(object@Model, boot.x),
              type = "user", extra = TRUE
            )
          bias.est <- (boot.est - tmp.list$est)
          ci <- (tmp.list$est - bias.est) + tmp.list$se %o% fac
        } else if (boot.ci.type == "basic") {
          ci <- cbind(tmp.list$est, tmp.list$est)
          alpha <- (1 + c(level, -level)) / 2

          # free.idx only
          qq <- apply(tmp.boot, 2, norm.inter, alpha)
          free.idx <- which(object@ParTable$free &
            !duplicated(object@ParTable$free))
          ci[free.idx, ] <- 2 * ci[free.idx, ] - t(qq[c(3, 4), ])

          # def.idx
          def.idx <- which(object@ParTable$op == ":=")
          if (length(def.idx) > 0L) {
            boot.def <- apply(tmp.boot, 1, object@Model@def.function)
            if (length(def.idx) == 1L) {
              boot.def <- as.matrix(boot.def)
            } else {
              boot.def <- t(boot.def)
            }
            qq <- apply(boot.def, 2, norm.inter, alpha)
            ci[def.idx, ] <- 2 * ci[def.idx, ] - t(qq[c(3, 4), ])
          }

          # TODO: add cin/ceq?
        } else if (boot.ci.type == "perc") {
          ci <- cbind(tmp.list$est, tmp.list$est)
          alpha <- (1 + c(-level, level)) / 2

          # free.idx only
          qq <- apply(tmp.boot, 2, norm.inter, alpha)
          free.idx <- which(object@ParTable$free &
            !duplicated(object@ParTable$free))
          ci[free.idx, ] <- t(qq[c(3, 4), ])

          # def.idx
          def.idx <- which(object@ParTable$op == ":=")
          if (length(def.idx) > 0L) {
            boot.def <- apply(tmp.boot, 1, object@Model@def.function)
            if (length(def.idx) == 1L) {
              boot.def <- as.matrix(boot.def)
            } else {
              boot.def <- t(boot.def)
            }
            qq <- apply(boot.def, 2, norm.inter, alpha)
            def.idx <- which(object@ParTable$op == ":=")
            ci[def.idx, ] <- t(qq[c(3, 4), ])
          }

          # TODO:  add cin/ceq?
        } else if (boot.ci.type == "bca.simple") {
          # no adjustment for scale!! only bias!!
          alpha <- (1 + c(-level, level)) / 2
          zalpha <- qnorm(alpha)
          ci <- cbind(tmp.list$est, tmp.list$est)

          # free.idx only
          free.idx <- which(object@ParTable$free &
            !duplicated(object@ParTable$free))
          x <- tmp.list$est[free.idx]
          for (i in seq_along(free.idx)) {
            t <- tmp.boot[, i]
            t <- t[is.finite(t)]
            t0 <- x[i]
            # check if we have variance (perhaps constrained to 0?)
            # new in 0.6-3
            if (var(t) == 0) {
              next
            }
            w <- qnorm(sum(t < t0) / length(t))
            a <- 0.0 #### !!! ####
            adj.alpha <- pnorm(w + (w + zalpha) / (1 - a * (w + zalpha)))
            qq <- norm.inter(t, adj.alpha)
            ci[free.idx[i], ] <- qq[, 2]
          }

          # def.idx
          def.idx <- which(object@ParTable$op == ":=")
          if (length(def.idx) > 0L) {
            x.def <- object@Model@def.function(x)
            boot.def <- apply(tmp.boot, 1, object@Model@def.function)
            if (length(def.idx) == 1L) {
              boot.def <- as.matrix(boot.def)
            } else {
              boot.def <- t(boot.def)
            }
            for (i in seq_along(def.idx)) {
              t <- boot.def[, i]
              t <- t[is.finite(t)]
              t0 <- x.def[i]
              w <- qnorm(sum(t < t0) / length(t))
              a <- 0.0 #### !!! ####
              adj.alpha <- pnorm(w + (w + zalpha) / (1 - a * (w + zalpha)))
              qq <- norm.inter(t, adj.alpha)
              ci[def.idx[i], ] <- qq[, 2]
            }
          }

          # TODO:
          # - add cin/ceq
        } else if (boot.ci.type == "bca") { # new in 0.6-12
          # we assume that the 'ordinary' (nonparametric) was used

          lavoptions <- object@Options
          nobs <- object@SampleStats@nobs
          ntotal <- object@SampleStats@ntotal

          # we need enough bootstrap runs
          if (nrow(tmp.boot) < ntotal) {
            lav_msg_stop(gettextf(
            "BCa confidence intervals require more (successful) bootstrap runs
            (%1$s) than the number of observations (%2$s).",
            nrow(tmp.boot), ntotal))
          }

          # does not work with sampling weights (yet)
          if (!is.null(object@Data@weights[[1]])) {
            lav_msg_stop(
              gettext("BCa confidence intervals not available in
                      the presence of sampling weights."))
          }

          # check if we have a seed
          if (is.null(bootstrap.seed)) {
            lav_msg_stop(gettext("seed not available in tmp.boot object."))
          }

          # compute 'X' matrix with frequency indices (to compute
          # the empirical influence values using regression)
          tmp.freq <- lav_bootstrap_indices(
            R = lavoptions$bootstrap,
            nobs = nobs, parallel = lavoptions$parallel[1],
            ncpus = lavoptions$ncpus, cl = lavoptions[["cl"]],
            iseed = bootstrap.seed, return.freq = TRUE,
            merge.groups = TRUE
          )
          if (length(error.idx) > 0L) {
            tmp.freq <- tmp.freq[-error.idx, , drop = FALSE]
          }
          stopifnot(nrow(tmp.freq) == nrow(tmp.boot))

          # compute empirical influence values (using regression)
          # remove first column per group
          first.idx <- sapply(object@Data@case.idx, "[[", 1L)
          tmp.lm <- lm.fit(x = cbind(1, tmp.freq[, -first.idx]), y = tmp.boot)
          tmp.beta <- unname(tmp.lm$coefficients)[-1, , drop = FALSE]
          tmp.ll <- rbind(0, tmp.beta)

          # compute 'a' for all parameters at once
          tmp.aa <- apply(tmp.ll, 2L, function(x) {
            tmp.l <- x - mean(x)
            sum(tmp.l^3) / (6 * sum(tmp.l^2)^1.5)
          })

          # adjustment for both bias AND scale
          alpha <- (1 + c(-level, level)) / 2
          zalpha <- qnorm(alpha)
          ci <- cbind(tmp.list$est, tmp.list$est)

          # free.idx only
          free.idx <- which(object@ParTable$free &
            !duplicated(object@ParTable$free))
          stopifnot(length(free.idx) == ncol(tmp.boot))
          x <- tmp.list$est[free.idx]
          for (i in seq_along(free.idx)) {
            t <- tmp.boot[, i]
            t <- t[is.finite(t)]
            t0 <- x[i]
            # check if we have variance (perhaps constrained to 0?)
            # new in 0.6-3
            if (var(t) == 0) {
              next
            }
            w <- qnorm(sum(t < t0) / length(t))
            a <- tmp.aa[i]
            adj.alpha <- pnorm(w + (w + zalpha) / (1 - a * (w + zalpha)))
            qq <- norm.inter(t, adj.alpha)
            ci[free.idx[i], ] <- qq[, 2]
          }

          # def.idx
          def.idx <- which(object@ParTable$op == ":=")
          if (length(def.idx) > 0L) {
            x.def <- object@Model@def.function(x)
            boot.def <- apply(tmp.boot, 1, object@Model@def.function)
            if (length(def.idx) == 1L) {
              boot.def <- as.matrix(boot.def)
            } else {
              boot.def <- t(boot.def)
            }

            # recompute empirical influence values
            tmp.lm <- lm.fit(x = cbind(1, tmp.freq[, -1]), y = boot.def)
            tmp.beta <- unname(tmp.lm$coefficients)[-1, , drop = FALSE]
            tmp.ll <- rbind(0, tmp.beta)

            # compute 'a' values for all def.idx parameters
            tmp.aa <- apply(tmp.ll, 2L, function(x) {
              tmp.l <- x - mean(x)
              sum(tmp.l^3) / (6 * sum(tmp.l^2)^1.5)
            })

            # compute bca ci
            for (i in seq_along(def.idx)) {
              t <- boot.def[, i]
              t <- t[is.finite(t)]
              t0 <- x.def[i]
              w <- qnorm(sum(t < t0) / length(t))
              a <- tmp.aa[i]
              adj.alpha <- pnorm(w + (w + zalpha) / (1 - a * (w + zalpha)))
              qq <- norm.inter(t, adj.alpha)
              ci[def.idx[i], ] <- qq[, 2]
            }
          }

          # TODO:
          # - add cin/ceq
        }
      }

      tmp.list$ci.lower <- ci[, 1]
      tmp.list$ci.upper <- ci[, 2]
    }

    # standardized estimates?
    # 28 March 2024: TDJ adds option to select specific types
    if (is.logical(standardized)) {
      if (standardized) {
        standardized <- c("std.lv", "std.all")
        if (length(lav_object_vnames(object, "ov.x")) && object@Options$fixed.x) {
          standardized <- c(standardized, "std.nox")
        }
      } else {
        standardized <- character(0)
      } # corresponds to standardized=FALSE
    } else {
      # !is.logical(standardized)
      standardized <- tolower(as.character(standardized))
      if ("std.nox" %in% standardized) {
        # sanity checks
        if (length(lav_object_vnames(object, "ov.x")) == 0) {
          lav_msg_note(gettext(
            "`std.nox' unavailable without fixed exogenous predictors"))
          standardized <- setdiff(standardized, "std.nox")
        } else if (!object@Options$fixed.x) {
          lav_msg_note(gettext("`std.nox' unavailable when fixed.x = FALSE"))
          standardized <- setdiff(standardized, "std.nox")
        }
      }
    }
    # Then add each requested type
    # (original source code, but now independently conditional)
    if ("std.lv" %in% standardized) {
      tmp.list$std.lv <- lav_standardize_lv(object, cov.std = cov.std)
    }
    if ("std.all" %in% standardized) {
      tmp.list$std.all <- lav_standardize_all(object,
        est.std = tmp.list$est.std,
        cov.std = cov.std
      )
    }
    if ("std.nox" %in% standardized) {
      tmp.list$std.nox <- lav_standardize_all_nox(object,
        est.std = tmp.list$est.std,
        cov.std = cov.std
      )
    }

    # rsquare?
    if (rsquare) {
      r2 <- lavTech(object, "rsquare", add.labels = TRUE)
      tmp.names <- unlist(lapply(r2, names))
      nel <- length(tmp.names)
      if (nel == 0L) {
        lav_msg_warn(
          gettext("rsquare = TRUE, but there are no dependent variables"))
      } else {
        if (lav_partable_nlevels(tmp.list) == 1L) {
          block <- rep(seq_along(r2), sapply(r2, length))
          first.block.idx <- which(!duplicated(tmp.list$block) &
            tmp.list$block > 0L)
          gval <- tmp.list$group[first.block.idx]
          if (length(gval) > 0L) {
            group <- rep(gval, sapply(r2, length))
          } else {
            # single block, single group
            group <- rep(1L, length(block))
          }
          r2 <- data.frame(
            lhs = tmp.names, op = rep("r2", nel),
            rhs = tmp.names, block = block, group = group,
            est = unlist(r2), stringsAsFactors = FALSE
          )
        } else {
          # add level column
          block <- rep(seq_along(r2), sapply(r2, length))
          first.block.idx <- which(!duplicated(tmp.list$block) &
            tmp.list$block > 0L)
          # always at least two blocks
          gval <- tmp.list$group[first.block.idx]
          group <- rep(gval, sapply(r2, length))
          lval <- tmp.list$level[first.block.idx]
          level <- rep(lval, sapply(r2, length))
          r2 <- data.frame(
            lhs = tmp.names, op = rep("r2", nel),
            rhs = tmp.names,
            block = block, group = group,
            level = level,
            est = unlist(r2), stringsAsFactors = FALSE
          )
        }
        # add step column if needed
        if (!is.null(tmp.list$step)) {
          r2$step <- 2L # per default
          # simplification: we assume that only the
          # observed indicators of latent variables are step 1
          ov.ind <- unlist(object@pta$vnames$ov.ind)
          step1.idx <- which(r2$lhs %in% ov.ind)
          r2$step[step1.idx] <- 1L
        }
        tmp.list <- lav_partable_merge(pt1 = tmp.list, pt2 = r2, warn = FALSE)
      }
    }

    # fractional missing information (if estimator="fiml")
    if (fmi) {
      se.orig <- tmp.list$se

      # new in 0.6-6, use 'EM' based (unstructured) sample statistics
      # otherwise, it would be as if we use expected info, while the
      # original use observed, producing crazy results
      if (object@Data@ngroups > 1L) {
        em.cov <- lapply(lavInspect(object, "sampstat.h1"), "[[", "cov")
        em.mean <- lapply(lavInspect(object, "sampstat.h1"), "[[", "mean")
      } else {
        em.cov <- lavInspect(object, "sampstat.h1")$cov
        em.mean <- lavInspect(object, "sampstat.h1")$mean
      }

      tmp.pt <- parTable(object)
      tmp.pt$ustart <- tmp.pt$est
      tmp.pt$start <- tmp.pt$est <- NULL

      this.options <- object@Options
      if (!is.null(fmi.options) && is.list(fmi.options)) {
        # modify original options
        this.options <- modifyList(this.options, fmi.options)
      }
      # override
      this.options$optim.method <- "none"
      this.options$sample.cov.rescale <- FALSE
      this.options$check.gradient <- FALSE
      this.options$baseline <- FALSE
      this.options$h1 <- FALSE
      this.options$test <- FALSE

      fit.complete <- lavaan(
        model = tmp.pt,
        sample.cov = em.cov,
        sample.mean = em.mean,
        sample.nobs = lavInspect(object, "nobs"),
        slotOptions = this.options
      )

      se.comp <- lavParameterEstimates(fit.complete,
        ci = FALSE, fmi = FALSE,
        zstat = FALSE, pvalue = FALSE, remove.system.eq = FALSE,
        remove.eq = FALSE, remove.ineq = FALSE,
        remove.def = FALSE, remove.nonfree = FALSE, remove.unused = FALSE,
        rsquare = rsquare, add.attributes = FALSE
      )$se

      se.comp <- ifelse(se.comp == 0.0, as.numeric(NA), se.comp)
      tmp.list$fmi <- 1 - (se.comp * se.comp) / (se.orig * se.orig)
    }

    # if single level, remove level column
    if (object@Data@nlevels == 1L) tmp.list$level <- NULL

    # if single group, remove group column
    if (object@Data@ngroups == 1L) tmp.list$group <- NULL

    # if single everything, remove block column
    if (object@Data@nlevels == 1L &&
      object@Data@ngroups == 1L) {
      tmp.list$block <- NULL
    }

    # if no user-defined labels, remove label column
    if (sum(nchar(object@ParTable$label)) == 0L) {
      tmp.list$label <- NULL
    }

    # if plabel = TRUE, add it (new in 0.6-20)
    if (plabel) {
      if (!is.null(tmp.partable$plabel)) {
        tmp.list$plabel <- tmp.partable$plabel
      } else {
        if (!is.null(tmp.partable$id)) {
          tmp.list$plabel <- paste(".p", tmp.list$id, ".", sep = "")
        } else {
          tmp.list$plabel <- paste(".p", seq_along(tmp.list$plabel),
                                   ".", sep = "")
        }
      }
    }

    # remove non-free parameters? (but keep ==, >, < and :=)
    if (remove.nonfree) {
      nonfree.idx <- which(tmp.list$free == 0L &
        !tmp.list$op %in% c("==", ">", "<", ":="))
      if (length(nonfree.idx) > 0L) {
        tmp.list <- tmp.list[-nonfree.idx, ]
      }
    }

    # remove 'unused' parameters
    # these are parameters that are automatically added (user == 0),
    # but with their final (est) values fixed to their default values
    # (typically 1 or 0).
    # currently only intercepts and scaling-factors (for now)
    # should we also remove fixed-to-1 variances? (parameterization = theta)?
    if (remove.unused) {
      # intercepts
      int.idx <- which(tmp.list$op == "~1" &
        tmp.list$user == 0L &
        tmp.list$free == 0L &
        tmp.list$est == 0)
      if (length(int.idx) > 0L) {
        tmp.list <- tmp.list[-int.idx, ]
      }

      # scaling factors
      scaling.idx <- which(tmp.list$op == "~*~" &
        tmp.list$user == 0L &
        tmp.list$free == 0L &
        tmp.list$est == 1)
      if (length(scaling.idx) > 0L) {
        tmp.list <- tmp.list[-scaling.idx, ]
      }
    }


    # remove 'free' column
    tmp.list$free <- NULL

    # remove == rows?
    if (remove.eq) {
      eq.idx <- which(tmp.list$op == "==" & tmp.list$user == 1L)
      if (length(eq.idx) > 0L) {
        tmp.list <- tmp.list[-eq.idx, ]
      }
    }
    if (remove.system.eq) {
      eq.idx <- which(tmp.list$op == "==" & tmp.list$user != 1L)
      if (length(eq.idx) > 0L) {
        tmp.list <- tmp.list[-eq.idx, ]
      }
    }
    # remove <> rows?
    if (remove.ineq) {
      ineq.idx <- which(tmp.list$op %in% c("<", ">"))
      if (length(ineq.idx) > 0L) {
        tmp.list <- tmp.list[-ineq.idx, ]
      }
    }
    # remove := rows?
    if (remove.def) {
      def.idx <- which(tmp.list$op == ":=")
      if (length(def.idx) > 0L) {
        tmp.list <- tmp.list[-def.idx, ]
      }
    }

    # remove step 1 rows?
    if (remove.step1 && !is.null(tmp.list$step)) {
      step1.idx <- which(tmp.list$step == 1L)
      if (length(step1.idx) > 0L) {
        tmp.list <- tmp.list[-step1.idx, ]
      }
      # remove step column
      tmp.list$step <- NULL
    }

    # remove attribute for data order
    attr(tmp.list, "ovda") <- NULL

    # remove tmp.list$user
    tmp.list$user <- NULL

    if (output == "text") {
      class(tmp.list) <- c(
        "lavaan.parameterEstimates", "lavaan.data.frame",
        "data.frame"
      )
      if (header) {
        attr(tmp.list, "categorical") <- object@Model@categorical
        attr(tmp.list, "parameterization") <- object@Model@parameterization
        attr(tmp.list, "information") <- object@Options$information[1]
        attr(tmp.list, "information.meat") <- object@Options$information.meat
        attr(tmp.list, "se") <- object@Options$se
        attr(tmp.list, "group.label") <- object@Data@group.label
        attr(tmp.list, "level.label") <- object@Data@level.label
        attr(tmp.list, "bootstrap") <- object@Options$bootstrap
        attr(tmp.list, "bootstrap.successful") <- bootstrap.successful
        attr(tmp.list, "missing") <- object@Options$missing
        attr(tmp.list, "observed.information") <-
          object@Options$observed.information[1]
        attr(tmp.list, "h1.information") <- object@Options$h1.information[1]
        attr(tmp.list, "h1.information.meat") <-
          object@Options$h1.information.meat
        attr(tmp.list, "header") <- header
        # FIXME: add more!!
      }
    } else {
      tmp.list$exo <- NULL
      tmp.list$lower <- tmp.list$upper <- NULL
      class(tmp.list) <- c("lavaan.data.frame", "data.frame")
    }

    tmp.list
  }
parameterEstimates <- lavParameterEstimates     # synonym   # nolint

parameterTable <- parametertable <- parTable <- partable <- # nolint
  function(object) {
    # check object
    object <- lav_object_check_version(object)

    # convert to data.frame
    out <- as.data.frame(object@ParTable, stringsAsFactors = FALSE)

    class(out) <- c("lavaan.data.frame", "data.frame")
    out
  }

varTable <- vartable <- function(object, ov.names = names(object), # nolint
                                 ov.names.x = NULL,
                                 ordered = NULL, factor = NULL,
                                 as.data.frame. = TRUE) { # nolint

  if (inherits(object, "lavaan")) {
    # check object
    object <- lav_object_check_version(object)
    tmp.var <- object@Data@ov
  } else if (inherits(object, "lavData")) {
    tmp.var <- object@ov
  } else if (inherits(object, "data.frame")) {
    tmp.var <- lav_dataframe_vartable(
      frame = object, ov.names = ov.names,
      ov.names.x = ov.names.x,
      ordered = ordered, factor = factor,
      as.data.frame. = FALSE
    )
  } else {
    lav_msg_stop(gettext("object must of class lavaan or a data.frame"))
  }

  if (as.data.frame.) {
    tmp.var <- as.data.frame(tmp.var,
      stringsAsFactors = FALSE,
      row.names = seq_along(tmp.var$name)
    )
    class(tmp.var) <- c("lavaan.data.frame", "data.frame")
  }

  tmp.var
}


setMethod(
  "fitted.values", "lavaan",
  function(object, type = "moments", labels = TRUE, ...) {
    dotdotdot <- list(...)
    if (length(dotdotdot) > 0L) {
      for (j in seq_along(dotdotdot)) {
        lav_msg_warn(gettextf(
          "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
          sQuote("fitted.values"))
        )
      }
    }
    # lowercase type
    type <- tolower(type)

    # check object
    object <- lav_object_check_version(object)

    # catch type="casewise"
    if (type %in% c("casewise", "case", "obs", "observations", "ov")) {
      return(lavPredict(object, type = "ov", label = labels))
    }

    lav_object_inspect_implied(object,
      add.labels = labels, add.class = TRUE,
      drop.list.single.group = TRUE
    )
  }
)


setMethod(
  "fitted", "lavaan",
  function(object, type = "moments", labels = TRUE, ...) {
    dotdotdot <- list(...)
    if (length(dotdotdot) > 0L) {
      for (j in seq_along(dotdotdot)) {
        lav_msg_warn(gettextf(
          "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
          sQuote("fitted"))
        )
      }
    }
    fitted.values(object, type = type, labels = labels)
  }
)

setMethod(
  "vcov", "lavaan",
  function(object, type = "free", labels = TRUE, remove.duplicated = FALSE,
           standardized = NULL, free.only = TRUE, ...) {
    dotdotdot <- list(...)
    if (length(dotdotdot) > 0L) {
      for (j in seq_along(dotdotdot)) {
        lav_msg_warn(gettextf(
          "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
          sQuote("vcov"))
        )
      }
    }
    # check object
    object <- lav_object_check_version(object)

    # check for convergence first!
    if (object@optim$npar > 0L && !object@optim$converged) {
      lav_msg_stop(gettext("model did not converge"))
    }

    if (object@Options$se == "none") {
      lav_msg_stop(gettext("vcov not available if se=\"none\""))
    }

    ## verify there are any user-defined parameters
    #FIXME? smarter to check @ParTable for $op == ":="?
    if (is.null(formals(object@Model@def.function))) {
      type <- "free" # avoids error in lav_object_inspect_vcov_def()
    }

    if (!is.null(standardized)) {
      standardized <- tolower(standardized[1])
      stopifnot(standardized %in% c("std.lv","std.all","std.nox"))
    }

    if (type == "user" || type == "joint" || type == "all" || type == "full" ||
      type == "complete") {
      if (remove.duplicated) {
        lav_msg_stop(gettext(
          "argument \"remove.duplicated\" not supported if type = \"user\""
        ))
      }
      tmp.varcov <- lav_object_inspect_vcov_def(object,
        joint = TRUE,
        standardized = !is.null(standardized),
        type = ifelse(is.null(standardized), "std.all", standardized),
        add.labels = labels,
        add.class = TRUE
      )
    } else if (type == "free") {
      tmp.varcov <- lav_object_inspect_vcov(object,
        standardized = !is.null(standardized),
        type = ifelse(is.null(standardized), "std.all", standardized),
        free.only = free.only,
        add.labels = labels,
        add.class = TRUE,
        remove.duplicated = remove.duplicated
      )
    } else {
      lav_msg_stop(gettext("type argument should be \"user\" or \"free\""))
    }

    tmp.varcov
  }
)


# logLik (so that we can use the default AIC/BIC functions from stats4(
setMethod(
  "logLik", "lavaan",
  function(object, ...) {
    dotdotdot <- list(...)
    if (length(dotdotdot) > 0L) {
      for (j in seq_along(dotdotdot)) {
        lav_msg_warn(gettextf(
          "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
          sQuote("logLik"))
        )
      }
    }
    # check object
    object <- lav_object_check_version(object)

    if (object@Options$estimator != "ML") {
      lav_msg_warn(gettext("logLik only available if estimator is ML"))
    }
    if (object@optim$npar > 0L && !object@optim$converged) {
      lav_msg_warn(gettext("model did not converge"))
    }

    # new in 0.6-1: we use the @loglik slot (instead of fitMeasures)
    tmp.logl <- object@loglik
    logl <- tmp.logl$loglik
    attr(logl, "df") <- tmp.logl$npar ### note: must be npar, not df!!
    attr(logl, "nobs") <- tmp.logl$ntotal
    class(logl) <- "logLik"
    logl
  }
)

# nobs
if (!exists("nobs", envir = asNamespace("stats4"))) {
  setGeneric("nobs", function(object, ...) standardGeneric("nobs"))
}
setMethod(
  "nobs", signature(object = "lavaan"),
  function(object, ...) {
    dotdotdot <- list(...)
    if (length(dotdotdot) > 0L) {
      for (j in seq_along(dotdotdot)) {
        lav_msg_warn(gettextf(
          "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
          sQuote("nobs"))
        )
      }
    }
    object@SampleStats@ntotal
  }
)

# see: src/library/stats/R/update.R
setMethod(
  "update", signature(object = "lavaan"),
  function(object, model, add, ..., evaluate = TRUE) {
    # check object
    object <- lav_object_check_version(object)

    call <- object@call
    if (is.null(call)) {
      lav_msg_stop(gettext("need an object with call slot"))
    }

    extras <- match.call(expand.dots = FALSE)$...

    if (!missing(model)) {
      # call$formula <- update.formula(formula(object), formula.)
      call$model <- model
    } else if (exists(as.character(call$model))) {
      call$model <- eval(call$model, parent.frame())
    } else if (is.character(call$model)) {
      ## do nothing
      ## call$model <- call$model
    } else {
      call$model <- parTable(object)
      call$model$est <- NULL
      call$model$se <- NULL
    }
    if (!is.null(call$slotParTable) && is.list(call$model)) {
      call$slotParTable <- call$model
    }

    if (length(extras) > 0) {
      ## check for call$slotOptions conflicts
      if (!is.null(call$slotOptions)) {
        same.names <- intersect(names(lavOptions()), names(extras))
        for (i in same.names) {
          call$slotOptions[[i]] <- extras[[i]]
          extras[i] <- NULL # not needed if they are in slotOptions
        }
      }
      existing <- !is.na(match(names(extras), names(call)))
      for (a in names(extras)[existing]) call[[a]] <- extras[[a]]
      if (any(!existing)) {
        call <- c(as.list(call), extras[!existing])
        call <- as.call(call)
      }
    }

    if (missing(add) && !evaluate) {
      return(call)
    }
    ## for any of the other 3 scenarios, we need the updated fit

    ## Check if "add" and "model" are both strings; combine them
    if (missing(add)) {
      add.allready.in.partable <- TRUE # because nothing to add
    } else {
      if (is.character(add) && is.character(call$model)) {
        call$model <- c(call$model, add)
        add.allready.in.partable <- TRUE
      } else {
        add.allready.in.partable <- FALSE
      }
    }
    newfit <- eval(call, parent.frame())
    if (add.allready.in.partable && evaluate) {
      return(newfit)
    }

    ## only remaining situations: "add" exists, but either "add" or "model"
    ## is a parameter table, so update the parameter table in the call
    if (!(mode(add) %in% c("list", "character"))) {
      lav_msg_stop(
        gettext("'add' argument must be model syntax or parameter table.
                See ?lav_model_partable help page.")
      )
    }
    tmp.pt <- lav_object_extended(newfit, add = add)@ParTable
    tmp.pt$user <- NULL # get rid of "10" category used in lavTestScore()
    ## group == 0L in new rows
    tmp.pt$group[tmp.pt$group == 0L] <- tmp.pt$block[tmp.pt$group == 0L]
    # tmp.pt$plabel == "" in new rows.  Consequences?
    tmp.pt$est <- NULL
    tmp.pt$se <- NULL
    call$model <- tmp.pt

    if (evaluate) {
      eval(call, parent.frame())
    } else {
      call
    }
  }
)

setMethod(
  "anova", signature(object = "lavaan"),
  function(object, ...) {
    # NOTE: if we add additional arguments, it is not the same generic
    # anova() function anymore, and match.call will be screwed up

    # NOTE: we need to extract the names of the models from match.call here,
    #       otherwise, we loose them in the call stack

    mcall <- match.call(expand.dots = TRUE)
    dots <- list(...)

    modp <- if (length(dots)) {
      sapply(dots, inherits, "lavaan")
    } else {
      logical(0)
    }
    tmp.names <- sapply(as.list(mcall)[c(FALSE, TRUE, modp)], deparse)

    lavTestLRT(object = object, ..., model.names = tmp.names)
  }
)

# YR 21 March 2015
# new approach to compute 'Gamma': the asymptotic variance matrix of
#                                  sqrt{N} times the
#                                  observed sample statistics (means + varcov)
#
# Gamma = N x ACOV[ ybar, vech(S) ]
#       = NACOV[ ybar, vech(S) ]
#
# - one single function for mean + cov
# - handle 'fixed.x' exogenous covariates


# - YR  3 Dec 2015: allow for conditional.x = TRUE
# - YR 22 Jan 2023: add model.based= argument (if object is lavaan object)
# - YR 30 May 2024: add lav_samplestats_cor_Gamma(_NT)

# generic public function (not exported yet)
# input for lavGamma can be lavobject, lavdata, data.frame, or matrix
lavGamma <- function(object, group = NULL, missing = "listwise",
                     ov.names.x = NULL, fixed.x = FALSE, conditional.x = FALSE,
                     meanstructure = FALSE, slopestructure = FALSE,
                     gamma.n.minus.one = FALSE, gamma.unbiased = FALSE,
                     ADF = TRUE, model.based = FALSE, NT.rescale = FALSE,
                     Mplus.WLS = FALSE, add.labels = FALSE) {
  # check object

  # 1. object is lavaan object
  if (inherits(object, "lavaan")) {
    object <- lav_object_check_version(object)
    lav_object_gamma(
      lavobject = object, ADF = ADF,
      model.based = model.based, Mplus.WLS = Mplus.WLS
    )
  } else if (inherits(object, "lavData")) {
    lavdata <- object
    model.based <- FALSE
  } else if (inherits(object, "data.frame") ||
    inherits(object, "matrix")) {
    model.based <- FALSE
    NAMES <- names(object)
    if (!is.null(NAMES) && !is.null(group)) {
      NAMES <- NAMES[-match(group, NAMES)]
    }
    lavdata <- lav_lavdata(
      data = object, group = group,
      ov.names = NAMES, ordered = NULL,
      ov.names.x = ov.names.x,
      lavoptions = list(
        warn = FALSE,
        missing = missing
      )
    )
  } else {
    lav_msg_stop(
      gettextf("lavGamma can not handle objects of class %s",
                lav_msg_view(class(object)))
    )
  }

  # extract data
  Y <- lavdata@X
  if (conditional.x) {
    eXo <- lavdata@eXo
    for (g in seq_len(lavdata@ngroups)) {
      Y[[g]] <- cbind(Y[[g]], eXo[[g]])
    }
  }

  # x.idx
  x.idx <- lapply(
    seq_len(lavdata@ngroups),
    function(g) {
      match(
        lavdata@ov.names.x[[g]],
        lavdata@ov.names[[g]]
      )
    }
  )

  OUT <- lapply(seq_len(lavdata@ngroups), function(g) {
    if (length(lavdata@cluster) > 0L) {
      cluster.idx <- lavdata@Lp[[g]]$cluster.idx[[2]]
    } else {
      cluster.idx <- NULL
    }
    if (ADF) {
      out <- lav_samplestats_Gamma(
        Y = Y[[g]],
        Mu = NULL,
        Sigma = NULL,
        x.idx = x.idx[[g]],
        cluster.idx = cluster.idx,
        fixed.x = fixed.x,
        conditional.x = conditional.x,
        meanstructure = meanstructure,
        slopestructure = conditional.x,
        gamma.n.minus.one = gamma.n.minus.one,
        unbiased = gamma.unbiased,
        Mplus.WLS = Mplus.WLS
      )
    } else {
      out <- lav_samplestats_Gamma_NT(
        Y = Y[[g]],
        wt = NULL, # for now
        rescale = NT.rescale,
        x.idx = x.idx[[g]],
        fixed.x = fixed.x,
        conditional.x = conditional.x,
        meanstructure = meanstructure,
        slopestructure = conditional.x
      )
    }
    out
  })

  # todo: labels

  OUT
}



# for internal use -- lavobject or internal slots
lav_object_gamma <- function(lavobject = NULL,
                             # or individual slots
                             lavdata = NULL,
                             lavoptions = NULL,
                             lavsamplestats = NULL,
                             lavh1 = NULL,
                             lavimplied = NULL,
                             # other options
                             ADF = TRUE, model.based = FALSE,
                             Mplus.WLS = FALSE) {
  # extract slots
  if (!is.null(lavobject)) {
    lavdata <- lavobject@Data
    lavoptions <- lavobject@Options
    lavsamplestats <- lavobject@SampleStats
    lavh1 <- lavobject@h1
    lavimplied <- lavobject@implied
  }

  missing <- lavoptions$missing
  if (!missing %in% c("listwise", "pairwise")) {
    model.based <- TRUE
  }
  fixed.x <- lavoptions$fixed.x
  conditional.x <- lavoptions$conditional.x
  meanstructure <- lavoptions$meanstructure
  gamma.n.minus.one <- lavoptions$gamma.n.minus.one
  gamma.unbiased <- lavoptions$gamma.unbiased

  if (ADF && model.based && conditional.x) {
    lav_msg_stop(gettext(
      "ADF + model.based + conditional.x is not supported yet."))
  }

  # output container
  OUT <- vector("list", length = lavdata@ngroups)

  # compute Gamma matrix for each group
  for (g in seq_len(lavdata@ngroups)) {
    x.idx <- lavsamplestats@x.idx[[g]]
    COV <- MEAN <- NULL
    if (!ADF || model.based) {
      implied <- lavh1$implied # saturated/unstructured
      if (model.based) {
        implied <- lavimplied # model-based/structured
      }
      if (conditional.x) {
        # convert to joint COV/MEAN
        res.S <- implied$res.cov[[g]]
        res.slopes <- implied$res.slopes[[g]]
        res.int <- implied$res.int[[g]]
        S.xx <- implied$cov.x[[g]]
        M.x <- implied$mean.x[[g]]

        S.yy <- res.S + res.slopes %*% S.xx %*% t(res.slopes)
        S.yx <- res.slopes %*% S.xx
        S.xy <- S.xx %*% t(res.slopes)
        M.y <- res.int + res.slopes %*% M.x

        COV <- rbind(cbind(S.yy, S.yx), cbind(S.xy, S.xx))
        MEAN <- c(M.y, M.x)
      } else {
        # not conditional.x
        COV <- implied$cov[[g]]
        MEAN <- implied$mean[[g]]
      }
    } # COV/MEAN

    if (ADF) {
      if (conditional.x) {
        Y <- cbind(lavdata@X[[g]], lavdata@eXo[[g]])
      } else {
        Y <- lavdata@X[[g]]
      }
      if (length(lavdata@cluster) > 0L) {
        cluster.idx <- lavdata@Lp[[g]]$cluster.idx[[2]]
      } else {
        cluster.idx <- NULL
      }
      OUT[[g]] <- lav_samplestats_Gamma(
        Y = Y,
        Mu = MEAN,
        Sigma = COV,
        x.idx = x.idx,
        cluster.idx = cluster.idx,
        fixed.x = fixed.x,
        conditional.x = conditional.x,
        meanstructure = meanstructure,
        slopestructure = conditional.x,
        gamma.n.minus.one = gamma.n.minus.one,
        unbiased = gamma.unbiased,
        Mplus.WLS = Mplus.WLS
      )
    } else {
      OUT[[g]] <- lav_samplestats_Gamma_NT(
        COV = COV, # joint!
        MEAN = MEAN, # joint!
        x.idx = x.idx,
        fixed.x = fixed.x,
        conditional.x = conditional.x,
        meanstructure = meanstructure,
        slopestructure = conditional.x
      )
    }

    # group.w.free
    if (lavoptions$group.w.free) {
      # checkme!
      OUT[[g]] <- lav_matrix_bdiag(matrix(1, 1, 1), OUT[[g]])
    }

  } # g

  OUT
}





# NOTE:
#  - three types:
#       1) plain         (conditional.x = FALSE, fixed.x = FALSE)
#       2) fixed.x       (conditional.x = FALSE, fixed.x = TRUE)
#       3) conditional.x (conditional.x = TRUE)
#  - if conditional.x = TRUE, we ignore fixed.x (can be TRUE or FALSE)

# NORMAL-THEORY
lav_samplestats_Gamma_NT <- function(Y = NULL, # should include
                                     # eXo if
                                     # conditional.x=TRUE
                                     wt = NULL,
                                     COV = NULL, # joint!
                                     MEAN = NULL, # joint!
                                     rescale = FALSE,
                                     x.idx = integer(0L),
                                     fixed.x = FALSE,
                                     conditional.x = FALSE,
                                     meanstructure = FALSE,
                                     slopestructure = FALSE) {
  # check arguments
  if (length(x.idx) == 0L) {
    conditional.x <- FALSE
    fixed.x <- FALSE
  }

  # compute COV from Y
  if (is.null(COV)) {
    stopifnot(!is.null(Y))

    # coerce to matrix
    Y <- unname(as.matrix(Y))
    N <- nrow(Y)
    if (is.null(wt)) {
      COV <- cov(Y)
      if (rescale) {
        COV <- COV * (N - 1) / N # (normal) ML version
      }
    } else {
      out <- stats::cov.wt(Y, wt = wt, method = "ML")
      COV <- out$cov
    }
  } else {
    if (!missing(rescale)) {
      lav_msg_warn(gettext("rescale= argument has no effect if COV is given"))
    }
    if (!missing(wt)) {
      lav_msg_warn(gettext("wt= argument has no effect if COV is given"))
    }
  }

  # if needed, compute MEAN from Y
  if (conditional.x && length(x.idx) > 0L && is.null(MEAN) &&
    (meanstructure || slopestructure)) {
    stopifnot(!is.null(Y))
    if (is.null(wt)) {
      MEAN <- colMeans(Y, na.rm = TRUE)
    } else {
      MEAN <- out$center
    }
  }

  # rename
  S <- COV
  M <- MEAN

  # unconditional
  if (!conditional.x) {
    # unconditional - stochastic x
    if (!fixed.x) {
      # if (lav_use_lavaanC()) {
      #   Gamma <- lavaanC::m_kronecker_dup_ginv_pre_post(S, multiplicator = 2.0)
      # } else {
        Gamma <- 2 * lav_matrix_duplication_ginv_pre_post(S %x% S)
      # }
      if (meanstructure) {
        Gamma <- lav_matrix_bdiag(S, Gamma)
      }

      # unconditional - fixed x
    } else {
      # handle fixed.x = TRUE

      # cov(Y|X) = A - B C^{-1} B'
      # where A = cov(Y), B = cov(Y,X), C = cov(X)
      A <- S[-x.idx, -x.idx, drop = FALSE]
      B <- S[-x.idx, x.idx, drop = FALSE]
      C <- S[x.idx, x.idx, drop = FALSE]
      YbarX <- A - B %*% solve(C, t(B))

      # reinsert YbarX in Y+X (residual) covariance matrix
      YbarX.aug <- matrix(0, nrow = NROW(S), ncol = NCOL(S))
      YbarX.aug[-x.idx, -x.idx] <- YbarX

      # take difference
      R <- S - YbarX.aug

      # if (lav_use_lavaanC()) {
      #   Gamma.S <- lavaanC::m_kronecker_dup_ginv_pre_post(S, multiplicator = 2.0)
      #   Gamma.R <- lavaanC::m_kronecker_dup_ginv_pre_post(R, multiplicator = 2.0)
      # } else {
        Gamma.S <- 2 * lav_matrix_duplication_ginv_pre_post(S %x% S)
        Gamma.R <- 2 * lav_matrix_duplication_ginv_pre_post(R %x% R)
      # }
      Gamma <- Gamma.S - Gamma.R

      if (meanstructure) {
        Gamma <- lav_matrix_bdiag(YbarX.aug, Gamma)
      }
    }
  } else {
    # conditional.x

    # 4 possibilities:
    # - no meanstructure, no slopes
    # -    meanstructure, no slopes
    # - no meanstructure, slopes
    # -    meanstructure, slopes

    # regress Y on X, and compute covariance of residuals 'R'
    A <- S[-x.idx, -x.idx, drop = FALSE]
    B <- S[-x.idx, x.idx, drop = FALSE]
    C <- S[x.idx, x.idx, drop = FALSE]
    Cov.YbarX <- A - B %*% solve(C) %*% t(B)
    # if (lav_use_lavaanC()) {
    #   Gamma <- lavaanC::m_kronecker_dup_ginv_pre_post(Cov.YbarX, multiplicator = 2.0)
    # } else {
      Gamma <- 2 * lav_matrix_duplication_ginv_pre_post(Cov.YbarX %x% Cov.YbarX)
    # }

    if (meanstructure || slopestructure) {
      MY <- M[-x.idx]
      MX <- M[x.idx]
      C3 <- rbind(
        c(1, MX),
        cbind(MX, C + tcrossprod(MX))
      )
      # B3 <- cbind(MY, B + tcrossprod(MY,MX))
    }

    if (meanstructure) {
      if (slopestructure) {
        # A11 <- solve(C3) %x% Cov.YbarX
        A11 <- Cov.YbarX %x% solve(C3)
      } else {
        # A11 <- solve(C3)[1, 1, drop=FALSE] %x% Cov.YbarX
        A11 <- Cov.YbarX %x% solve(C3)[1, 1, drop = FALSE]
      }
    } else {
      if (slopestructure) {
        # A11 <- solve(C3)[-1, -1, drop=FALSE] %x% Cov.YbarX
        A11 <- Cov.YbarX %x% solve(C3)[-1, -1, drop = FALSE]
      } else {
        A11 <- matrix(0, 0, 0)
      }
    }

    Gamma <- lav_matrix_bdiag(A11, Gamma)
  }

  Gamma
}

# NOTE:
#  - three types:
#       1) plain         (conditional.x = FALSE, fixed.x = FALSE)
#       2) fixed.x       (conditional.x = FALSE, fixed.x = TRUE)
#       3) conditional.x (conditional.x = TRUE)
#  - if conditional.x = TRUE, we ignore fixed.x (can be TRUE or FALSE)
#
#  - new in 0.6-1: if Mu/Sigma is provided, compute 'model-based' Gamma
#                  (only if conditional.x = FALSE, for now)
#  - new in 0.6-2: if cluster.idx is not NULL, correct for clustering
#  - new in 0.6-13: add unbiased = TRUE (for the 'plain' setting only)

# ADF THEORY
lav_samplestats_Gamma <- function(Y, # Y+X if cond!
                                  Mu = NULL,
                                  Sigma = NULL,
                                  x.idx = integer(0L),
                                  cluster.idx = NULL,
                                  fixed.x = FALSE,
                                  conditional.x = FALSE,
                                  meanstructure = FALSE,
                                  slopestructure = FALSE,
                                  gamma.n.minus.one = FALSE,
                                  unbiased = FALSE,
                                  Mplus.WLS = FALSE) {
  # coerce to matrix
  Y <- unname(as.matrix(Y))
  N <- nrow(Y)
  p <- ncol(Y)

  # unbiased?
  if (unbiased) {
    if (conditional.x || fixed.x || !is.null(Sigma) ||
      !is.null(cluster.idx)) {
      lav_msg_stop(
        gettext("unbiased Gamma only available for the simple
        (not conditional.x or fixed.x or model-based or clustered) setting."))
    } else {
	  # data really should be complete
      COV <- COV.unbiased <- stats::cov(Y, use = "pairwise.complete.obs")
      COV <- COV * (N - 1) / N
      cov.vech <- lav_matrix_vech(COV)
    }
  }

  # model-based?
  if (!is.null(Sigma)) {
    stopifnot(!conditional.x)
    model.based <- TRUE
    if (meanstructure) {
      stopifnot(!is.null(Mu))
      sigma <- c(as.numeric(Mu), lav_matrix_vech(Sigma))
    } else {
      Mu <- colMeans(Y, na.rm = TRUE) # for centering!
      sigma <- lav_matrix_vech(Sigma)
    }
  } else {
    model.based <- FALSE
  }

  # denominator
  if (gamma.n.minus.one) {
    N <- N - 1
  }

  # check arguments
  if (length(x.idx) == 0L) {
    conditional.x <- FALSE
    fixed.x <- FALSE
  }
  if (Mplus.WLS) {
    stopifnot(!conditional.x, !fixed.x)
  }

  if (!conditional.x && !fixed.x) {
    # center, so we can use crossprod instead of cov
    if (model.based) {
      Yc <- t(t(Y) - as.numeric(Mu))
    } else {
      Yc <- t(t(Y) - colMeans(Y, na.rm = TRUE))
    }

    # create Z where the rows_i contain the following elements:
    #  - Y_i (if meanstructure is TRUE)
    #  - vech(Yc_i' %*% Yc_i) where Yc_i are the residuals
    idx1 <- lav_matrix_vech_col_idx(p)
    idx2 <- lav_matrix_vech_row_idx(p)
    if (meanstructure) {
      Z <- cbind(Y, Yc[, idx1, drop = FALSE] *
        Yc[, idx2, drop = FALSE])
    } else {
      Z <- (Yc[, idx1, drop = FALSE] *
        Yc[, idx2, drop = FALSE])
    }

    if (model.based) {
      if (meanstructure) {
        stopifnot(!is.null(Mu))
        sigma <- c(as.numeric(Mu), lav_matrix_vech(Sigma))
      } else {
        sigma <- lav_matrix_vech(Sigma)
      }
      Zc <- t(t(Z) - sigma)
    } else {
      Zc <- t(t(Z) - colMeans(Z, na.rm = TRUE))
    }

    # clustered?
    if (length(cluster.idx) > 0L) {
      Zc <- rowsum(Zc, cluster.idx)
    }

    if (anyNA(Zc)) {
      Gamma <- lav_matrix_crossprod(Zc) / N
    } else {
      Gamma <- base::crossprod(Zc) / N
    }
  } else if (!conditional.x && fixed.x) {
    if (model.based) {
      Yc <- t(t(Y) - as.numeric(Mu))
      Y.bar <- colMeans(Y, na.rm = TRUE)
      res.cov <- (Sigma[-x.idx, -x.idx, drop = FALSE] -
        Sigma[-x.idx, x.idx, drop = FALSE] %*%
        solve(Sigma[x.idx, x.idx, drop = FALSE]) %*%
        Sigma[x.idx, -x.idx, drop = FALSE])
      res.slopes <- (solve(Sigma[x.idx, x.idx, drop = FALSE]) %*%
        Sigma[x.idx, -x.idx, drop = FALSE])
      res.int <- (Y.bar[-x.idx] -
        as.numeric(colMeans(Y[, x.idx, drop = FALSE],
          na.rm = TRUE
        ) %*% res.slopes))
      x.bar <- Y.bar[x.idx]
      yhat.bar <- as.numeric(res.int + as.numeric(x.bar) %*% res.slopes)
      YHAT.bar <- numeric(p)
      YHAT.bar[-x.idx] <- yhat.bar
      YHAT.bar[x.idx] <- x.bar
      YHAT.cov <- Sigma
      YHAT.cov[-x.idx, -x.idx] <- Sigma[-x.idx, -x.idx] - res.cov


      yhat <- cbind(1, Y[, x.idx]) %*% rbind(res.int, res.slopes)
      YHAT <- Y
      YHAT[, -x.idx] <- yhat
      # YHAT <- cbind(yhat, Y[,x.idx])
      YHATc <- t(t(YHAT) - YHAT.bar)
      idx1 <- lav_matrix_vech_col_idx(p)
      idx2 <- lav_matrix_vech_row_idx(p)
      if (meanstructure) {
        Z <- (cbind(Y, Yc[, idx1, drop = FALSE] *
          Yc[, idx2, drop = FALSE]) -
          cbind(YHAT, YHATc[, idx1, drop = FALSE] *
            YHATc[, idx2, drop = FALSE]))
        sigma1 <- c(Mu, lav_matrix_vech(Sigma))
        sigma2 <- c(YHAT.bar, lav_matrix_vech(YHAT.cov))
      } else {
        Z <- (Yc[, idx1, drop = FALSE] *
          Yc[, idx2, drop = FALSE] -
          YHATc[, idx1, drop = FALSE] *
            YHATc[, idx2, drop = FALSE])
        sigma1 <- lav_matrix_vech(Sigma)
        sigma2 <- lav_matrix_vech(YHAT.cov)
      }
      Zc <- t(t(Z) - (sigma1 - sigma2))
    } else {
      QR <- qr(cbind(1, Y[, x.idx, drop = FALSE]))
      yhat <- qr.fitted(QR, Y[, -x.idx, drop = FALSE])
      # YHAT <- cbind(yhat, Y[,x.idx])
      YHAT <- Y
      YHAT[, -x.idx] <- yhat

      Yc <- t(t(Y) - colMeans(Y, na.rm = TRUE))
      YHATc <- t(t(YHAT) - colMeans(YHAT, na.rm = TRUE))
      idx1 <- lav_matrix_vech_col_idx(p)
      idx2 <- lav_matrix_vech_row_idx(p)
      if (meanstructure) {
        Z <- (cbind(Y, Yc[, idx1, drop = FALSE] *
          Yc[, idx2, drop = FALSE]) -
          cbind(YHAT, YHATc[, idx1, drop = FALSE] *
            YHATc[, idx2, drop = FALSE]))
      } else {
        Z <- (Yc[, idx1, drop = FALSE] *
          Yc[, idx2, drop = FALSE] -
          YHATc[, idx1, drop = FALSE] *
            YHATc[, idx2, drop = FALSE])
      }
      Zc <- t(t(Z) - colMeans(Z, na.rm = TRUE))
    }

    # clustered?
    if (length(cluster.idx) > 0L) {
      Zc <- rowsum(Zc, cluster.idx)
    }

    if (anyNA(Zc)) {
      Gamma <- lav_matrix_crossprod(Zc) / N
    } else {
      Gamma <- base::crossprod(Zc) / N
    }
  } else {
    # conditional.x

    # 4 possibilities:
    # - no meanstructure, no slopes
    # -    meanstructure, no slopes
    # - no meanstructure, slopes
    # -    meanstructure, slopes

    # regress Y on X, and compute residuals
    X <- cbind(1, Y[, x.idx, drop = FALSE])
    QR <- qr(X)
    RES <- qr.resid(QR, Y[, -x.idx, drop = FALSE])
    p <- ncol(RES)

    idx1 <- lav_matrix_vech_col_idx(p)
    idx2 <- lav_matrix_vech_row_idx(p)

    if (meanstructure || slopestructure) {
      XtX.inv <- unname(solve(crossprod(X)))
      Xi <- (X %*% XtX.inv) * N ## FIXME, shorter way?
      ncX <- NCOL(X)
      ncY <- NCOL(RES)
    }

    if (meanstructure) {
      if (slopestructure) {
        # Xi.idx <- rep(seq_len(ncX), each  = ncY)
        # Res.idx <- rep(seq_len(ncY), times = ncX)
        Xi.idx <- rep(seq_len(ncX), times = ncY)
        Res.idx <- rep(seq_len(ncY), each = ncX)
        Z <- cbind(
          Xi[, Xi.idx, drop = FALSE] *
            RES[, Res.idx, drop = FALSE],
          RES[, idx1, drop = FALSE] *
            RES[, idx2, drop = FALSE]
        )
      } else {
        Xi.idx <- rep(1L, each = ncY)
        Z <- cbind(
          Xi[, Xi.idx, drop = FALSE] *
            RES,
          RES[, idx1, drop = FALSE] *
            RES[, idx2, drop = FALSE]
        )
      }
    } else {
      if (slopestructure) {
        # Xi.idx <- rep(seq_len(ncX), each  = ncY)
        # Xi.idx <- Xi.idx[ -seq_len(ncY) ]
        Xi.idx <- rep(seq(2, ncX), times = ncY)
        # Res.idx <- rep(seq_len(ncY), times = (ncX - 1L))
        Res.idx <- rep(seq_len(ncY), each = (ncX - 1L))
        Z <- cbind(
          Xi[, Xi.idx, drop = FALSE] *
            RES[, Res.idx, drop = FALSE],
          RES[, idx1, drop = FALSE] *
            RES[, idx2, drop = FALSE]
        )
      } else {
        Z <- RES[, idx1, drop = FALSE] * RES[, idx2, drop = FALSE]
      }
    }

    if (model.based) {
      Zc <- t(t(Z) - sigma)
    } else {
      Zc <- t(t(Z) - colMeans(Z, na.rm = TRUE))
    }

    # clustered?
    if (length(cluster.idx) > 0L) {
      Zc <- rowsum(Zc, cluster.idx)
    }

    if (anyNA(Zc)) {
      Gamma <- lav_matrix_crossprod(Zc) / N
    } else {
      Gamma <- base::crossprod(Zc) / N
    }
  }


  # only to mimic Mplus when estimator = "WLS"
  if (Mplus.WLS && !fixed.x && !conditional.x) {
    # adjust G_22 (the varcov part)
    S <- cov(Y, use = "pairwise")
    w <- lav_matrix_vech(S)
    w.biased <- (N - 1) / N * w
    diff <- outer(w, w) - outer(w.biased, w.biased)
    if (meanstructure) {
      Gamma[-seq_len(p), -seq_len(p)] <-
        Gamma[-seq_len(p), -seq_len(p), drop = FALSE] - diff
    } else {
      Gamma <- Gamma - diff
    }

    if (meanstructure) {
      # adjust G_12/G_21 (third-order)
      # strange rescaling?
      N1 <- (N - 1) / N
      Gamma[seq_len(p), -seq_len(p)] <- Gamma[seq_len(p), -seq_len(p)] * N1
      Gamma[-seq_len(p), seq_len(p)] <- Gamma[-seq_len(p), seq_len(p)] * N1
    }
  }

  # clustered?
  if (length(cluster.idx) > 0L) {
    nC <- nrow(Zc)
    Gamma <- Gamma * nC / (nC - 1)
  }

  # unbiased?
  if (unbiased) {
    # normal-theory Gamma (cov only)
    # if (lav_use_lavaanC()) {
    #   GammaNT.cov <- lavaanC::m_kronecker_dup_ginv_pre_post(COV,
    #                                                         multiplicator = 2.0)
    # } else {
      GammaNT.cov <- 2 * lav_matrix_duplication_ginv_pre_post(COV %x% COV)
    # }

    if (meanstructure) {
      Gamma.cov <- Gamma[-(1:p), -(1:p), drop = FALSE]
      Gamma.mean.cov <- Gamma[1:p, -(1:p), drop = FALSE]
    } else {
      Gamma.cov <- Gamma
    }

    # Browne's unbiased DF estimator (COV part)
    Gamma.u <- (N * (N - 1) / (N - 2) / (N - 3) * Gamma.cov -
      N / (N - 2) / (N - 3) * (GammaNT.cov -
        2 / (N - 1) * tcrossprod(cov.vech)))
    if (meanstructure) {
      Gamma <- lav_matrix_bdiag(COV, Gamma.u)

      # 3-rd order:
      Gamma[1:p, (p + 1):ncol(Gamma)] <- Gamma.mean.cov * N / (N - 2)
      Gamma[(p + 1):ncol(Gamma), 1:p] <- t(Gamma.mean.cov * N / (N - 2))
    } else {
      Gamma <- Gamma.u
    }
  } # unbiased

  Gamma
}

# ADF Gamma for correlations
#
# 30 May 2024: basic version: fixed.x=FALSE, conditional.x=FALSE, ...
lav_samplestats_cor_Gamma <- function(Y, meanstructure = FALSE) {

  # coerce to matrix
  Y <- unname(as.matrix(Y))
  N <- nrow(Y)
  P <- ncol(Y)

  # compute S and R
  S <- cov(Y) * (N - 1) / N
  R <- cov2cor(S)

  # create z-scores
  SD <- sqrt(diag(S))
  Yz <- t( (t(Y) - colMeans(Y))/SD )

  # create squared z-scores
  Yz2 <- Yz*Yz

  # find indices so we avoid 1) double subscripts (diagonal!), and
  #                          2) duplicated subscripts (symmetric!)
  idx1 <- lav_matrix_vech_col_idx(P, diagonal = FALSE)
  idx2 <- lav_matrix_vech_row_idx(P, diagonal = FALSE)

  ZR1 <- (Yz[, idx1, drop = FALSE] * Yz[, idx2, drop = FALSE])
  ZR2 <- (Yz2[, idx1, drop = FALSE] + Yz2[, idx2, drop = FALSE])
  ZR2 <- t( t(ZR2) * lav_matrix_vech(R, diagonal = FALSE) )
  ZRR <- ZR1 - 0.5*ZR2
  if(meanstructure) {
      ZRR <- cbind(Yz, ZRR)
  }
  Gamma <- crossprod(ZRR)/N

  Gamma
}

# normal theory version
# 30 May 2024: basic version: fixed.x=FALSE, conditional.x=FALSE, ...
lav_samplestats_cor_Gamma_NT <- function(Y = NULL,
                                         wt = NULL,
                                         COV = NULL, # joint!
                                         MEAN = NULL, # joint!
                                         rescale = FALSE,
                                         x.idx = integer(0L),
                                         fixed.x = FALSE,
                                         conditional.x = FALSE,
                                         meanstructure = FALSE,
                                         slopestructure = FALSE) {
  # check arguments
  if (length(x.idx) == 0L) {
    conditional.x <- FALSE
    fixed.x <- FALSE
  } else {
    lav_msg_stop(gettext("x.idx not supported (yet) for correlations; use
                          fixed.x = FALSE (for now)"))
  }
  if(conditional.x) {
    lav_msg_stop(gettext("conditional.x = TRUE not supported (yet) for
                          correlations"))
  }

  # compute COV from Y
  if (is.null(COV)) {
    stopifnot(!is.null(Y))

    # coerce to matrix
    Y <- unname(as.matrix(Y))
    N <- nrow(Y)
    if (is.null(wt)) {
      COV <- cov(Y)
      if (rescale) {
        COV <- COV * (N - 1) / N # (normal) ML version
      }
    } else {
      out <- stats::cov.wt(Y, wt = wt, method = "ML")
      COV <- out$cov
    }
  } else {
    if (!missing(rescale)) {
      lav_msg_warn(gettext("rescale= argument has no effect if COV is given"))
    }
    if (!missing(wt)) {
      lav_msg_warn(gettext("wt= argument has no effect if COV is given"))
    }
  }

  # if needed, compute MEAN from Y
  if (conditional.x && length(x.idx) > 0L && is.null(MEAN) &&
    (meanstructure || slopestructure)) {
    stopifnot(!is.null(Y))
    if (is.null(wt)) {
      MEAN <- colMeans(Y, na.rm = TRUE)
    } else {
      MEAN <- out$center
    }
  }

  # rename
  S <- COV
  R <- cov2cor(S)
  M <- MEAN
  P <- nrow(S)

  # unconditional
  if (!conditional.x) {
    # unconditional - stochastic x
    if (!fixed.x) {
      IP <- diag(P) %x% R
      RR <- R %x% R
      Gamma.Z.NT <- RR + lav_matrix_commutation_pre(RR)
      tmp <- (IP + lav_matrix_commutation_pre(IP))/2
      zero.idx <- seq_len(P*P)[-lav_matrix_diag_idx(P)]
      tmp[, zero.idx] <- 0
      A <- -tmp
      diag(A) <- 1 - diag(tmp)
      Gamma.NT.big <- A %*% Gamma.Z.NT %*% t(A)
      r.idx <- lav_matrix_vech_idx(P, diagonal = FALSE)
      Gamma <- Gamma.NT.big[r.idx, r.idx]

      if (meanstructure) {
        Gamma <- lav_matrix_bdiag(R, Gamma)
      }

      # unconditional - fixed x
    } else {
      # TODO
    }
  } else {
    # conditional.x
    # TODO
  }

  Gamma
}

# LDW 26 Mar 2024: use option settings and store in cache environment

lavaan_cache_env <- new.env(parent = emptyenv())

# # function to get or set the switch to use c++ code in lavaanC
# lav_use_lavaanC <- uselavaanC <- function(x) {
#   if (missing(x)) {
#     if (!exists("opt.lavaanC", lavaan_cache_env)) {
#       assign("opt.lavaanC", requireNamespace("lavaanC", quietly = TRUE), lavaan_cache_env)
#     }
#     return(get("opt.lavaanC", lavaan_cache_env))
#   } else {
#     if (!is.logical(x) || length(x) != 1L)
#       lav_msg_stop(gettext("'x' must be a scalar logical"))
#     if (x) {
#       if (!requireNamespace("lavaanC", quietly = TRUE)) {
#         lav_msg_warn(gettext("cannot use lavaanC, package not found."))
#         assign("opt.lavaanC", FALSE, lavaan_cache_env)
#         return(invisible(NULL))
#       }
#     }
#     assign("opt.lavaanC", x, lavaan_cache_env)
#     return(invisible(NULL))
#   }
# }

# functions to handle warn/debug/verbose options
#             (no longer in 'standard' options)
# if x not present returns the current value of opt.warn/debug/verbose
# if x present
#   if x different from current value, assign x to current value and return TRUE
#   else return FALSE
lav_warn <- function(x) {
  optwarn <- get0("opt.warn", lavaan_cache_env, ifnotfound = TRUE)
  if (missing(x)) {
    return(optwarn)
  } else {
    setwarn <- as.logical(x)
    if (setwarn != optwarn) {
      if (setwarn) {
        # because default TRUE, removing value is the same as setting to TRUE
        rm("opt.warn", envir = lavaan_cache_env)
      } else {
        assign("opt.warn", FALSE, lavaan_cache_env)
      }
      return(TRUE)
    } else {
      return(FALSE)
    }
  }
}
lav_debug <- function(x) {
  optdebug <- get0("opt.debug", lavaan_cache_env, ifnotfound = FALSE)
  if (missing(x)) {
    return(optdebug)
  } else {
    setdebug <- as.logical(x)
    if (setdebug != optdebug) {
      if (setdebug) {
        assign("opt.debug", TRUE, lavaan_cache_env)
      } else {
        # because default FALSE, removing value is the same as setting to FALSE
        rm("opt.debug", envir = lavaan_cache_env)
      }
      return(TRUE)
    } else {
      return(FALSE)
    }
  }
}
lav_verbose <- function(x) {
  optverbose <- get0("opt.verbose", lavaan_cache_env, ifnotfound = FALSE)
  if (missing(x)) {
    return(optverbose)
  } else {
    setverbose <- as.logical(x)
    if (setverbose != optverbose) {
      if (setverbose) {
        assign("opt.verbose", TRUE, lavaan_cache_env)
      } else {
        # because default FALSE, removing value is the same as setting to FALSE
        rm("opt.verbose", envir = lavaan_cache_env)
      }
      return(TRUE)
    } else {
      return(FALSE)
    }
  }
}

# set the default options (including unspecified values "default")
lav_options_default <- function() {
  if (exists("opt.default", lavaan_cache_env)) {
    opt <- get("opt.default", lavaan_cache_env)
    return(opt)
  }
  # ---------------- preparation -----------------
  opt.default <- list()
  opt.check <- list()
  elm <- function(
    name = NULL,          # name of option, if length 2 first is sublist name
    dflt = NULL,          # default value
    chr = NULL,           # valid strings (names) and replacement values
    nm = NULL,            # valid numeric interval
    bl = FALSE,           # logical OK?
    oklen = c(1L, 1L),    # lengte > 1 OK, second negative to have a warning
    #                and not an error when length greater then abs(oklen[2])
    num2int = FALSE       # should numerical values be converted to int?
  ) {
    stopifnot(any(length(name) == 1:2))
    stopifnot(is.null(nm) || (length(nm) == 1 && grepl("^[][].*,.*[][]$", nm)))
    stopifnot(length(bl) == 1, is.logical(bl))
    stopifnot(is.null(chr) || is.character(chr))
    stopifnot(length(oklen) == 2, oklen[1] <= abs(oklen[2]))
    stopifnot(length(num2int) == 1, is.logical(num2int))

    # prepare list to store for checking option
    list2store <- list(oklen = oklen)
    if (!is.null(chr)) {
      if (is.null(names(chr))) names(chr) <- chr
      list2store$chr <- chr
    }
    if (!is.null(nm)) {
      first.in <- grepl("^\\[", nm)
      last.in <- grepl("\\]$", nm)
      elems <- as.numeric(strsplit(gsub("[][ ]", "", nm), ",")[[1]])
      if (num2int) {
        elems[elems == -Inf] <- -2e9
        elems[elems == Inf] <- 2e9
        elems <- as.integer(elems)
      }
      list2store$nm <- list(bounds = elems,
                            first.in = first.in, last.in = last.in)
    }
    if (bl) list2store$bl <- TRUE
    if (num2int) list2store$num2int <- TRUE

    # store default and list for checking
    if (length(name) == 1) name <- c("", name)
    if (name[1] != "") {
      if (is.null(opt.default[[name[1]]])) { # make sure sublists exist
        opt.default[[name[1]]] <<- list()
        sublist <- list()
        attr(sublist, "SUB") <- TRUE # indicate as sublist
        opt.check[[name[1]]] <<- sublist
      }
      opt.default[[name[1]]][[name[2]]] <<- dflt
      if (is.null(dflt)) opt.default[[name[1]]][name[2]] <<- list(NULL)
      opt.check[[name[1]]][[name[2]]] <<- list2store
    } else {
      opt.default[[name[2]]] <<- dflt
      if (is.null(dflt)) opt.default[name[2]] <<- list(NULL)
      opt.check[[name[2]]] <<- list2store
    }
    NULL
  }
  elmdup <- function(
    name = NULL, # name(s) of option
    from = NULL  # name(s) of option to duplicatie
  ) {
    if (length(name) == 1) name <- c("", name)
    if (length(from) == 1) from <- c("", from)
    if (from[1] != "") {
      from.default <- opt.default[[from[1]]][[from[2]]]
      from.check <- opt.check[[from[1]]][[from[2]]]
    } else {
      from.default <- opt.default[[from[2]]]
      from.check <- opt.check[[from[2]]]
    }
    if (name[1] != "") {
      if (is.null(opt.default[[name[1]]])) { # make sure sublists exist
        opt.default[[name[1]]] <<- list()
        sublist <- list()
        attr(sublist, "SUB") <- TRUE # indicate as sublist
        opt.check[[name[1]]] <<- sublist
      }
      opt.default[[name[1]]][[name[2]]] <<- from.default
      opt.check[[name[1]]][[name[2]]] <<- from.check
    } else {
      opt.default[[name[2]]] <<- from.default
      opt.check[[name[2]]] <<- from.check
    }
  }
  # ------------------------- store options --------------------------
  elm("model.type", "sem", chr = c(lavaan = "lavaan", cfa = "cfa",
            growth = "growth", sem = "sem", efa = "efa", path = "path",
            unrestricted = "unrestricted"))

  # global
  elm("mimic", "lavaan", chr = c(default = "lavaan", lavaan = "lavaan",
                                 regression = "lm", lisrel = "EQS",
                                 eqs = "EQS", lm = "lm", mplus = "Mplus"
  ))
  elm("gls.v11.mplus", "default", chr = "default", bl = TRUE)
  elm("gamma.vcov.mplus", "default", chr = "default", bl = TRUE)
  elm("gamma.wls.mplus", "default", chr = "default", bl = TRUE)
  elm("information.expected.mplus", "default", chr = "default", bl = TRUE)

  # model modifiers
  elm("meanstructure", "default", chr = "default", bl = TRUE)
  elm("int.ov.free", FALSE, bl = TRUE)
  elm("int.lv.free", FALSE, bl = TRUE)
  elm("marker.int.zero", FALSE, bl = TRUE) # fix maker intercepts
  # free lv means
  elm("conditional.x", "default", chr = "default", bl = TRUE)
  elm("fixed.x", "default", chr = "default", bl = TRUE)
  elm("orthogonal", FALSE, bl = TRUE)
  elm("orthogonal.x", FALSE, bl = TRUE)
  elm("orthogonal.y", FALSE, bl = TRUE)
  elm("std.lv", FALSE, bl = TRUE)
  elm("correlation", FALSE, bl = TRUE) # correlation structure
  elm("effect.coding", FALSE, chr = c("",
                                      "loadings", "intercepts",
                                      "mg.lv.efa.variances", "mg.lv.variances",
                                      "mg.lv.means", "mg.lv.intercepts"),
      bl = TRUE, oklen = c(0L, 6L))
  elm("ceq.simple", FALSE, bl = TRUE) # treat simple eq cons special?
  elm("parameterization", "default", c(
    "default", "mml", "delta", "theta"))
  elm("auto.fix.first", FALSE, bl = TRUE)
  elm("auto.fix.single", FALSE, bl = TRUE)
  elm("auto.var", FALSE, bl = TRUE)
  elm("auto.cov.lv.x", FALSE, bl = TRUE)
  elm("auto.cov.y", FALSE, bl = TRUE)
  elm("auto.th", FALSE, bl = TRUE)
  elm("auto.delta", FALSE, bl = TRUE)
  elm("auto.efa", FALSE, bl = TRUE)
  elm("composites", TRUE, bl = TRUE)

  # rotation
  elm("rotation", "geomin", chr = c(crawfer = "cf", crawford.ferguson = "cf",
    crawfordferguson = "cf", cf = "cf",
    varimax = "varimax", quartimax = "quartimax", orthomax = "orthomax",
    oblimin = "oblimin", quartimin = "quartimin", geomin = "geomin",
    entropy = "entropy", mccammon = "mccammon", infomax = "infomax",
    tandem1 = "tandem1", tandem2 = "tandem2", none = "none", promax = "promax",
    oblimax = "oblimax", bentler = "bentler", simplimax = "simplimax",
    target.strict = "target.strict", target = "pst", pst = "pst",
    cf.quartimax = "cf-quartimax", cf.varimax = "cf-varimax",
    cf.equamax = "cf-equamax", cf.parsimax = "cf-parsimax",
    cf.facparsim = "cf-facparsim", bi.quartimin = "biquartimin",
    biquartimin = "biquartimin", bi.geomin = "bigeomin", bigeomin = "bigeomin"
  ))
  elm("rotation.se", "bordered", chr = c("delta", "bordered"))

  # rotation-args sublist
  elm(c("rotation.args", "orthogonal"), FALSE, bl = TRUE)
  elm(c("rotation.args", "row.weights"), "default", chr = c(
    default = "default", kaiser = "kaiser", none = "none",
    cureton.mulaik = "cm", cm = "cm"))
  elm(c("rotation.args", "std.ov"), TRUE, bl = TRUE)
  elm(c("rotation.args", "geomin.epsilon"), 0.001, nm = "]0, 1.00]")
  # was 0.01 < 0.6-10
  elm(c("rotation.args", "orthomax.gamma"), 1, nm = "[0, 1]")
  elm(c("rotation.args", "cf.gamma"), 0, nm = "[0, 1]")
  elm(c("rotation.args", "oblimin.gamma"), 0, nm = "[0, 1000]")
  elm(c("rotation.args", "promax.kappa"), 4, nm = "[0, 1000]")
  elm(c("rotation.args", "target"), matrix(0, 0L, 0L), oklen = c(0, 1e+32))
  elm(c("rotation.args", "target.mask"), matrix(0, 0L, 0L), oklen = c(0, 1e+32))
  elm(c("rotation.args", "rstarts"), 30L, nm = "[0, 1e+07]")
  elm(c("rotation.args", "algorithm"), "gpa", chr = c("gpa", "pairwise"))
  elm(c("rotation.args", "reflect"), TRUE, bl = TRUE)
  elm(c("rotation.args", "order.lv.by"), "index",
      chr = c("sumofsquares", "index", "none"))
  elm(c("rotation.args", "gpa.tol"), 1e-05, nm = "]0, 0.01]")
  elm(c("rotation.args", "tol"), 1e-08, nm = "]0, 0.01]")
  elm(c("rotation.args", "warn"), FALSE, bl = TRUE)
  elm(c("rotation.args", "verbose"), FALSE, bl = TRUE)
  elm(c("rotation.args", "jac.init.rot"), TRUE, bl = TRUE)
  elm(c("rotation.args", "max.iter"), 10000L, nm = "[0, 1e+12]")
  elm(c("rotation.args", "mg.agreement"), FALSE, bl = TRUE)
  elm(c("rotation.args", "mg.agreement.weight"), 0.5, nm = "[0, 1]")
  elm(c("rotation.args", "mg.agreement.algorithm"), "pairwise",
    chr = c("pairwise", "lg"))
  elm(c("rotation.args", "mg.agreement.method"), "procrustes",
    chr = c("procrustes", "loading.alignment"))

  # full data
  elm("std.ov", FALSE, bl = TRUE)
  elm("missing", "default", chr = c(
    default = "default", ml = "ml", direct = "ml",
    ml.x = "ml.x", direct.x = "ml.x", fiml.x = "ml.x", fiml = "ml",
    two.stage = "two.stage", twostage = "two.stage", two.step = "two.stage",
    twostep = "two.stage", robust.two.stage = "robust.two.stage",
    robust.twostage = "robust.two.stage",
    robust.two.step = "robust.two.stage",
    robust.twostep = "robust.two.stage",
    two.stage.robust = "robust.two.stage",
    twostage.robust = "robust.two.stage",
    two.step.robust = "robust.two.stage",
    twostep.robust = "robust.two.stage",
    listwise = "listwise", pairwise = "pairwise",
    available.cases = "available.cases", doubly.robust = "doubly.robust"))
  elm("sampling.weights.normalization", "total", chr = c(
    "total", "group", "none"))
  elm("samplestats", TRUE, bl = TRUE)

  # summary data
  elm("sample.cov.rescale", "default", bl = TRUE)
  elm("sample.cov.robust", FALSE, bl = TRUE)
  elm("sample.icov", TRUE, bl = TRUE)
  elm("ridge", FALSE, bl = TRUE)
  elm("ridge.constant", "default", chr = "default", nm = "[0, Inf[")

  # multiple groups !!! group.label and group.partial capitals OK !!!
  elm("group.label", NULL, oklen = c(0L, 100L)) # no checks
  elm("group.equal", "", chr =
        c("", "none", "loadings", "intercepts", "means", "composite.loadings",
          "composite.weights",
          "regressions", "residuals", "residual.covariances", "thresholds",
          "lv.variances", "lv.covariances"), oklen = c(0L, 100L))
  elm("group.partial", "", oklen = c(0L, 100L)) # no checks
  elm("group.w.free", FALSE, bl = TRUE)

  # clusters
  elm("level.label", NULL, oklen = c(0L, 100L)) # no checks

  # estimation
  elm("estimator", "default", chr = c(
    none = "none", default = "default", wlsmv = "wlsmv", ml = "ml", mlr = "mlr",
    mlf = "mlf", mlm = "mlm", mlmv = "mlmv", mlmvs = "mlmvs", gls = "gls",
    wls = "wls", wlsm = "wlsm", uls = "uls", ulsm = "ulsm", ulsmv = "ulsmv",
    pml = "pml", dls = "dls", ntrls = "ntrls", catml = "catml",
    dwls = "dwls", wlsmvs = "wlsmvs", ulsmvs = "ulsmvs", fml = "fml",
    umn = "fml", reml = "reml", mml = "mml", fabin = "fabin2",
    fabin2 = "fabin2", fabin3 = "fabin3", mgm = "mgm", guttman = "mgm",
    gutman = "mgm", gutmann = "mgm", guttman1952 = "mgm",
    js = "js", jsa = "jsa", james.stein = "js",
    james.stein.aggregated = "jsa", bentler = "bentler1982",
    bentler1982 = "bentler1982", miiv = "iv", iv = "iv",
    miiv.2sls = "iv"
  ))
  elmdup("estimator.orig", "estimator")

  elm("estimator.args", list(), oklen = c(0L, 100L))
  elm("likelihood", "default", chr = c("default", "normal", "wishart"))
  elm("link", "default", chr = c("default", "logit", "probit"))
  elm("representation", "default", chr = c(
    default = "LISREL", lisrel = "LISREL", ram = "RAM"))
  elm("do.fit", TRUE, bl = TRUE)
  elm("bounds", "none", chr = c(
    "none", "default", "standard", "user", "wide", "wide.zerovar", "pos.var",
    "pos.ov.var", "pos.lv.var"))      # new in 0.6-6
  elm("rstarts", 0L, nm = "[0, 10000]", num2int = TRUE) # new in 0.6-18

  # inference
  elm("se", "default", chr = c(
    default = "default", none = "none", standard = "standard",
    robust.huber.white = "robust.huber.white", robust = "robust",
    robust.cluster = "robust.cluster",
    robust.cluster.sem = "robust.cluster.sem",
    sandwich = "robust.huber.white", robust.sem = "robust.sem",
    robust.sem.nt = "robust.sem.nt",
    two.stage = "two.stage", robust.two.stage = "robust.two.stage",
    bootstrap = "bootstrap", boot = "bootstrap", first.order = "first.order",
    robust.mlm.nt = "robust.sem.nt",
    robust.mlm = "robust.sem", robust.mlr = "robust.huber.white",
    observed = "observed", expected = "expected"),
    oklen = c(1L, -1L)
  )
  elm("test", "default", oklen = c(1L, 100L))
                  # checks for 'test' are in lav_test_rename !!!

  # information (se + test)
  elm("information", c("default", "default"), chr = c(
    "default", "expected", "observed", "first.order"),
    oklen = c(1L, 2L))
  elm("h1.information", c("structured", "structured"), chr = c(
    "structured", "unstructured"), oklen =  c(1L, 2L))
  elm("observed.information", c("hessian", "default"), chr = c(
    "default", "hessian", "h1"), oklen =  c(1L, 2L))

  # information se only
  elm("information.meat", "default",
      chr = c(default = "first.order", first.order = "first.order"))
  elm("h1.information.meat", "default", chr = c(
    "default", "structured", "unstructured"))

  # information for 'Omega' (yuan-benter test only)
  elm("omega.information", "default", chr = c(
    "default", "expected", "observed"
  ))
  elm("omega.h1.information", "default", chr = c(
    "default", "structured", "unstructured"
  ))
  elm("omega.information.meat", "default", chr = c(
    default = "first.order", first.order = "first.order"
  ))
  elm("omega.h1.information.meat", "default", chr = c(
    "default", "structured", "unstructured"
  ))

  # test statistic for fit measures
  elm("standard.test", "standard", oklen = c(1L, 100L))

  # test statistic for scaling
  elm("scaled.test", "standard", oklen = c(1L, 100L))

  # old approach trace.UGamma2
  elm("ug2.old.approach", FALSE, bl = TRUE)

  # bootstrap
  elm("bootstrap", list(R = 1000L))

  # gamma
  elm("gamma.n.minus.one", FALSE, bl = TRUE)
  elm("gamma.unbiased", FALSE, bl = TRUE)

  # optimization
  elm("control", list(), oklen = c(0L, 100L))
  elm("optim.method", "default", chr = c(
    "nlminb", "nlminb0", "nlminb1", "nlminb2",
    "bfgs", "l.bfgs.b", "gn", "default", "noniter", "none", "em"
  )) # gn for DLS, nlminb rest
  elm("optim.attempts", 4L, nm = "[1, 4]")
  elm("optim.force.converged", FALSE, bl = TRUE)
  elm("optim.gradient", "analytic", chr = c(
    analytic = "analytic", analytical = "analytic",
    numeric = "numerical", numerical = "numerical"
  ))
  elm("optim.init_nelder_mead", FALSE, bl = TRUE)
  elm("optim.var.transform", "none", chr = c(
    "none", "sqrt"
  ))
  elm("optim.parscale", "none", chr = c(
    none = "none", st = "standardized", stand = "standardized",
    standardize = "standardized", standardized = "standardized"
  ))
  elm("optim.partrace", FALSE, bl = TRUE)
  elm("optim.dx.tol", 1e-03, nm = "]0, 0.01]") # not too strict
  elm("optim.bounds", list(), oklen = c(0L, 100L))
  elm("em.iter.max", 10000L, nm = "[100, 1e8]", num2int = TRUE)
  elm("em.fx.tol", 1e-08, nm = "]0, 0.01]")
  elm("em.dx.tol", 1e-04, nm = "]0, 0.01]")
  elm("em.zerovar.offset", 0.0001, nm = "]0, 0.01]")
  elm("em.h1.iter.max", 500L, nm = "[10, 1e7]", num2int = TRUE)
  elm("em.h1.tol", 1e-05, nm = "]0, 0.01]") # was 1e-06 < 0.6-9
  elm("em.h1.warn", TRUE, bl = TRUE)
  elm("optim.gn.iter.max", 200L, nm = "[100, 1e8]", num2int = TRUE)
  elm("optim.gn.stephalf.max", 10L, nm = "[1, 1e8]", num2int = TRUE)
  elm("optim.gn.tol.x", 1e-05, nm = "]0, 0.01]")

  # numerical integration
  elm("integration.ngh", 21L, nm = "[1, 1000]", num2int = TRUE)

  # parallel
  elm("parallel", "no", chr = c(
    "no", "multicore", "snow"
  ))
  maxcpu <- max(1L, parallel::detectCores() - 1L)
  elm("ncpus", maxcpu, nm = paste0("[1,", maxcpu, "]"))
  elm("cl", NULL, oklen = c(0L, 1L))
  elm("iseed", NULL, oklen = c(0L, 1L))

  # categorical
  elm("zero.add", c(0.5, 0.0), chr = "default",
      nm = "[0, 1]", oklen = c(1L, -2L))
  elm("zero.keep.margins", "default", chr = "default", bl = TRUE)
  elm("zero.cell.warn", FALSE, bl = TRUE) # since 0.6-1
  elm("allow.empty.cell", FALSE, bl = TRUE) # since 0.6-19
  elm("cat.wls.w", TRUE, bl = TRUE) # since 0.6-18

  # starting values (char values checked in lav_options_set())
  elm("start", "default", oklen = c(1L, 1000L))

  # sanity checks
  elm("check.start", TRUE, bl = TRUE)
  elm("check.sigma.pd", "chol", chr = c("chol", "eigen")) # stored in env
  elm("check.post", TRUE, bl = TRUE)
  elm("check.gradient", TRUE, bl = TRUE)
  elm("check.vcov", TRUE, bl = TRUE)
  elm("check.lv.names", TRUE, bl = TRUE)
  elm("check.lv.interaction", TRUE, bl = TRUE)
  elm("check.delta.cat.mediator", TRUE, bl = TRUE)

  # more models/info
  elm("h1", TRUE, bl = TRUE)
  elm("baseline", TRUE, bl = TRUE)
  elm("baseline.type", "independence", chr = c(indep = "independence",
    independence = "independence", nested = "nested"))
  elm("baseline.conditional.x.free.slopes", TRUE, bl = TRUE)
  elm("baseline.fixed.x.free.cov", TRUE, bl = TRUE)
  elm("implied", TRUE, bl = TRUE)
  elm("loglik", TRUE, bl = TRUE)

  # storage of information
  elm("store.vcov", "default", chr = "default", bl = TRUE)

  # internal
  elm("parser", "new", chr = c(old = "old", orig = "old", new = "new",
                               c.r = "c.r", cr = "c.r", classic = "old"))

  # categorical
  elm("categorical", "default", chr = "default", bl = TRUE)

  # sort list and sublists
  for (nm in names(opt.default)) {
      if (is.list(opt.default[[nm]]))
        opt.default[[nm]] <- opt.default[[nm]][sort(names(opt.default[[nm]]))]
    }
  opt.default <- opt.default[sort(names(opt.default))]
  # ------------- store info in lavaan environment ---------------
  assign("opt.default", opt.default, lavaan_cache_env)
  assign("opt.check", opt.check, lavaan_cache_env)
  assign("opt.check.sigma.pd", "chol", lavaan_cache_env)

  # return defaults
  return(opt.default)
}

# public function
lavOptions <- function(x = NULL, default = NULL, mimic = "lavaan") { # nolint
  lavoptions <- lav_options_default()

  # selection only
  if (!is.null(x)) {
    if (is.character(x)) {
      # lower case only
      x <- tolower(x)

      # check if x is in names(lavoptions)
      not.ok <- which(!x %in% names(lavoptions))
      if (length(not.ok) > 0L) {
        lav_msg_warn(gettextf(
          "option(s) %s not available", lav_msg_view(x[not.ok]))
        )
        x <- x[-not.ok]
      }

      # return requested option(s)
      if (length(x) == 0L) {
        return(default)
      } else {
        lavoptions[x]
      }
    } else {
      lav_msg_stop(gettext("`x' must be a character string"))
    }
  } else {
    lavoptions
  }
}

# loglikelihood clustered/twolevel data

# YR: first version around Feb 2017
# YR 28 Oct 2024: [EM steps:] if fx.delta is NA, check if we have (near)-perfect
#                 correlations, and provide an informative warning


# take model-implied mean+variance matrices, and reorder/augment them
# to facilitate computing of (log)likelihood in the two-level case

# when conditional.x = FALSE:
# - sigma.w and sigma.b: same dimensions, level-1 variables only
# - sigma.zz: level-2 variables only
# - sigma.yz: cov(level-1, level-2)
# - mu.y: level-1 variables only (mu.w + mu.b)
# - mu.w: y within  part
# - mu.b: y between part
# - mu.z: level-2 variables only
lav_mvnorm_cluster_implied22l <- function(Lp = NULL,
                                          implied = NULL,
                                          Mu.W = NULL,
                                          Mu.B = NULL,
                                          Sigma.W = NULL,
                                          Sigma.B = NULL) {
  if (!is.null(implied)) {
    # FIXME: only for single-group analysis!
    Sigma.W <- implied$cov[[1]]
    Mu.W <- implied$mean[[1]]

    Sigma.B <- implied$cov[[2]]
    Mu.B <- implied$mean[[2]]
  }

  # within/between.idx
  between.idx <- Lp$between.idx[[2]]
  within.idx <- Lp$within.idx[[2]]
  both.idx <- Lp$both.idx[[2]]

  # ov.idx per level
  ov.idx <- Lp$ov.idx

  # 'tilde' matrices: ALL variables within and between
  p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]])))

  # Sigma.W.tilde
  Sigma.W.tilde <- matrix(0, p.tilde, p.tilde)
  Sigma.W.tilde[ov.idx[[1]], ov.idx[[1]]] <- Sigma.W

  # Sigma.B.tilde
  Sigma.B.tilde <- matrix(0, p.tilde, p.tilde)
  Sigma.B.tilde[ov.idx[[2]], ov.idx[[2]]] <- Sigma.B

  # Mu.W.tilde
  Mu.W.tilde <- numeric(p.tilde)
  Mu.W.tilde[ov.idx[[1]]] <- Mu.W

  # Mu.B.tilde
  Mu.B.tilde <- numeric(p.tilde)
  Mu.B.tilde[ov.idx[[2]]] <- Mu.B

  # add Mu.W[within.idx] to Mu.B
  Mu.WB.tilde <- numeric(p.tilde)
  Mu.WB.tilde[within.idx] <- Mu.W.tilde[within.idx]
  Mu.WB.tilde[both.idx] <- (Mu.B.tilde[both.idx] +
    Mu.W.tilde[both.idx])

  # set Mu.W[both.idx] to zero (after we added to WB)
  Mu.W.tilde[both.idx] <- 0
  # get Mu.B[both.idx[ from WB
  Mu.B.tilde[both.idx] <- Mu.WB.tilde[both.idx]

  # map to matrices needed for loglik
  if (length(within.idx) > 0L) {
    Mu.B.tilde[within.idx] <- 0
  }
  if (length(between.idx) > 0L) {
    mu.z <- Mu.B.tilde[between.idx]
    mu.y <- Mu.WB.tilde[-between.idx]
    mu.w <- Mu.W.tilde[-between.idx]
    mu.b <- Mu.B.tilde[-between.idx]
    sigma.zz <- Sigma.B.tilde[between.idx, between.idx, drop = FALSE]
    sigma.yz <- Sigma.B.tilde[-between.idx, between.idx, drop = FALSE]
    sigma.b <- Sigma.B.tilde[-between.idx, -between.idx, drop = FALSE]
    sigma.w <- Sigma.W.tilde[-between.idx, -between.idx, drop = FALSE]
  } else {
    mu.z <- numeric(0L)
    mu.y <- Mu.WB.tilde
    mu.w <- Mu.W.tilde
    mu.b <- Mu.B.tilde
    sigma.zz <- matrix(0, 0L, 0L)
    sigma.yz <- matrix(0, nrow(Sigma.B.tilde), 0L)
    sigma.b <- Sigma.B.tilde
    sigma.w <- Sigma.W.tilde
  }

  list(
    sigma.w = sigma.w, sigma.b = sigma.b, sigma.zz = sigma.zz,
    sigma.yz = sigma.yz, mu.z = mu.z, mu.y = mu.y, mu.w = mu.w,
    mu.b = mu.b
  )
}

lav_mvnorm_cluster_2l2implied <- function(Lp,
                                          sigma.w = NULL,
                                          sigma.b = NULL,
                                          sigma.zz = NULL,
                                          sigma.yz = NULL,
                                          mu.z = NULL,
                                          mu.y = NULL,
                                          mu.w = NULL,
                                          mu.b = NULL) {
  # between.idx
  between.idx <- Lp$between.idx[[2]]
  within.idx <- Lp$within.idx[[2]]
  both.idx <- Lp$both.idx[[2]]

  # ov.idx per level
  ov.idx <- Lp$ov.idx

  # 'tilde' matrices: ALL variables within and between
  p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]])))

  # if we have mu.y, convert to mu.w and mu.b
  if (!is.null(mu.y)) {
    mu.b <- mu.y
    mu.w.tilde <- numeric(p.tilde)
    mu.w.tilde[ov.idx[[1]]] <- mu.y

    # NO NEED TO SET THIS TO ZERO!
    # otherwise, we get non-symmetric Hessian!! 0.6-5

    # if(length(within.idx) > 0L) {
    #    mu.w.tilde[  -within.idx ] <- 0
    # } else {
    #    mu.w.tilde[] <- 0
    # }
    mu.w <- mu.w.tilde[ov.idx[[1]]]
  }

  # new in 0.6-18: ensure mu.w[both.idx] is zero?
  # NO: we get Hessian is not fully symmetric again!!
  # only do this at the very end (post-estimation)

  # Mu.W.tilde <- numeric(p.tilde)
  # Mu.B.tilde <- numeric(p.tilde)
  # Mu.W.tilde[ov.idx[[1]]] <- mu.w
  # Mu.B.tilde[ov.idx[[2]]] <- mu.b
  # Mu.B.tilde[between.idx] <- mu.z
  # if (length(within.idx) > 0) {
  #   Mu.B.tilde[within.idx] <- 0
  # }
  # Mu.B.tilde[both.idx] <- Mu.W.tilde[both.idx] + Mu.B.tilde[both.idx]
  # Mu.W.tilde[both.idx] <- 0
  # Mu.W <- Mu.W.tilde[ov.idx[[1]]]
  # Mu.B <- Mu.B.tilde[ov.idx[[2]]]

  Mu.W.tilde <- numeric( p.tilde )
  ###### DEBUG ##############
  #if(length(within.idx) > 0) {
      Mu.W.tilde[ ov.idx[[1]] ] <- mu.w
  #}
  ###########################
  Mu.W <- Mu.W.tilde[ ov.idx[[1]] ]

  # Mu.B
  Mu.B.tilde <- numeric(p.tilde)
  Mu.B.tilde[ ov.idx[[1]] ] <- mu.b
  Mu.B.tilde[ between.idx ] <- mu.z
  if(length(within.idx) > 0) {
      Mu.B.tilde[within.idx] <- 0
  }
  Mu.B <- Mu.B.tilde[ ov.idx[[2]] ]


  # Sigma.W
  Sigma.W <- sigma.w

  # Sigma.B
  Sigma.B.tilde <- matrix(0, p.tilde, p.tilde)
  Sigma.B.tilde[ov.idx[[1]], ov.idx[[1]]] <- sigma.b
  Sigma.B.tilde[ov.idx[[1]], between.idx] <- sigma.yz
  Sigma.B.tilde[between.idx, ov.idx[[1]]] <- t(sigma.yz)
  Sigma.B.tilde[between.idx, between.idx] <- sigma.zz
  Sigma.B <- Sigma.B.tilde[ov.idx[[2]], ov.idx[[2]], drop = FALSE]

  list(Mu.W = Mu.W, Mu.B = Mu.B, Sigma.W = Sigma.W, Sigma.B = Sigma.B)
}


# Mu.W, Mu.B, Sigma.W, Sigma.B are the model-implied statistics
# (not yet reordered)
lav_mvnorm_cluster_loglik_samplestats_2l <- function(YLp = NULL,
                                                     Lp = NULL,
                                                     Mu.W = NULL,
                                                     Sigma.W = NULL,
                                                     Mu.B = NULL,
                                                     Sigma.B = NULL,
                                                     Sinv.method = "eigen",
                                                     log2pi = FALSE,
                                                     minus.two = TRUE) {
  # map implied to 2l matrices
  out <- lav_mvnorm_cluster_implied22l(
    Lp = Lp, Mu.W = Mu.W, Mu.B = Mu.B,
    Sigma.W = Sigma.W, Sigma.B = Sigma.B
  )
  mu.y <- out$mu.y
  mu.z <- out$mu.z
  sigma.w <- out$sigma.w
  sigma.b <- out$sigma.b
  sigma.zz <- out$sigma.zz
  sigma.yz <- out$sigma.yz

  # Lp
  nclusters <- Lp$nclusters[[2]]
  cluster.size <- Lp$cluster.size[[2]]
  between.idx <- Lp$between.idx[[2]]
  cluster.sizes <- Lp$cluster.sizes[[2]]
  ncluster.sizes <- Lp$ncluster.sizes[[2]]
  cluster.size.ns <- Lp$cluster.size.ns[[2]]

  # Y1 samplestats
  if (length(between.idx) > 0L) {
    S.PW <- YLp[[2]]$Sigma.W[-between.idx, -between.idx, drop = FALSE]
  } else {
    S.PW <- YLp[[2]]$Sigma.W
  }

  # Y2 samplestats
  cov.d <- YLp[[2]]$cov.d
  mean.d <- YLp[[2]]$mean.d

  # common parts:
  sigma.w.inv <- lav_matrix_symmetric_inverse(
    S = sigma.w,
    logdet = TRUE, Sinv.method = Sinv.method
  )
  sigma.w.logdet <- attr(sigma.w.inv, "logdet")
  attr(sigma.w.inv, "logdet") <- NULL

  if (length(between.idx) > 0L) {
    sigma.zz.inv <- lav_matrix_symmetric_inverse(
      S = sigma.zz,
      logdet = TRUE, Sinv.method = Sinv.method
    )
    sigma.zz.logdet <- attr(sigma.zz.inv, "logdet")
    attr(sigma.zz.inv, "logdet") <- NULL
    sigma.yz.zi <- sigma.yz %*% sigma.zz.inv
    sigma.zi.zy <- t(sigma.yz.zi)
    sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy
  } else {
    sigma.zz.logdet <- 0
    sigma.b.z <- sigma.b
  }

  # min 2* logliklihood
  L <- numeric(ncluster.sizes) # logdet
  B <- numeric(ncluster.sizes) # between qf
  for (clz in seq_len(ncluster.sizes)) {
    # cluster size
    nj <- cluster.sizes[clz]

    # data between
    Y2Yc <- (cov.d[[clz]] + tcrossprod(mean.d[[clz]] - c(mu.z, mu.y)))

    # FIXME: avoid reorder/b.idx, so we can use between.idx
    if (length(between.idx) > 0L) {
      b.idx <- seq_len(length(Lp$between.idx[[2]]))
      Y2Yc.zz <- Y2Yc[b.idx, b.idx, drop = FALSE]
      Y2Yc.yz <- Y2Yc[-b.idx, b.idx, drop = FALSE]
      Y2Yc.yy <- Y2Yc[-b.idx, -b.idx, drop = FALSE]
    } else {
      Y2Yc.yy <- Y2Yc
    }

    # construct sigma.j
    sigma.j <- (nj * sigma.b.z) + sigma.w
    sigma.j.inv <- lav_matrix_symmetric_inverse(
      S = sigma.j,
      logdet = TRUE, Sinv.method = Sinv.method
    )
    sigma.j.logdet <- attr(sigma.j.inv, "logdet")
    attr(sigma.j.inv, "logdet") <- NULL

    # check: what if sigma.j is non-pd? should not happen
    if (is.na(sigma.j.logdet)) {
      # stop, and return NA right away
      # return(as.numeric(NA))
      # FORCE?
      # sigma.j <- lav_matrix_symmetric_force_pd(sigma.j)
      # sigma.j.inv <- lav_matrix_symmetric_inverse(S = sigma.j,
      #           logdet = TRUE, Sinv.method = Sinv.method)
      # sigma.j.logdet <- attr(sigma.j.inv, "logdet")
      # attr(sigma.j.inv, "logdet") <- NULL
    }

    # logdet -- between only
    L[clz] <- (sigma.zz.logdet + sigma.j.logdet)

    if (length(between.idx) > 0L) {
      # part 1 -- zz
      sigma.ji.yz.zi <- sigma.j.inv %*% sigma.yz.zi
      Vinv.11 <- sigma.zz.inv + nj * (sigma.zi.zy %*% sigma.ji.yz.zi)
      q.zz <- sum(Vinv.11 * Y2Yc.zz)

      # part 2 -- yz
      q.yz <- -nj * sum(sigma.ji.yz.zi * Y2Yc.yz)
    } else {
      q.zz <- q.yz <- 0
    }

    # part 5 -- yyc
    q.yyc <- -nj * sum(sigma.j.inv * Y2Yc.yy)

    # qf -- between only
    B[clz] <- q.zz + 2 * q.yz - q.yyc
  }
  # q.yya + q.yyb
  # the reason why we multiply the trace by 'N - nclusters' is
  # S.PW has been divided by 'N - nclusters'
  q.W <- sum(cluster.size - 1) * sum(sigma.w.inv * S.PW)
  # logdet within part
  L.W <- sum(cluster.size - 1) * sigma.w.logdet

  # -2*times logl (without the constant)
  loglik <- sum(L * cluster.size.ns) + sum(B * cluster.size.ns) + q.W + L.W

  # functions below compute -2 * logl
  if (!minus.two) {
    loglik <- loglik / (-2)
  }

  # constant
  # Note: total 'N' = (nobs * #within vars) + (nclusters * #between vars)
  if (log2pi) {
    LOG.2PI <- log(2 * pi)
    nWithin <- length(c(Lp$both.idx[[2]], Lp$within.idx[[2]]))
    nBetween <- length(Lp$between.idx[[2]])
    P <- Lp$nclusters[[1]] * nWithin + Lp$nclusters[[2]] * nBetween
    constant <- -(P * LOG.2PI) / 2
    loglik <- loglik + constant
  }

  # loglik.x (only if loglik is requested)
  if (length(unlist(Lp$ov.x.idx)) > 0L && log2pi && !minus.two) {
    loglik <- loglik - YLp[[2]]$loglik.x
  }

  loglik
}


# first derivative -2*logl wrt Mu.W, Mu.B, Sigma.W, Sigma.B
lav_mvnorm_cluster_dlogl_2l_samplestats <- function(YLp = NULL,
                                                    Lp = NULL,
                                                    Mu.W = NULL,
                                                    Sigma.W = NULL,
                                                    Mu.B = NULL,
                                                    Sigma.B = NULL,
                                                    return.list = FALSE,
                                                    Sinv.method = "eigen") {
  # map implied to 2l matrices
  out <- lav_mvnorm_cluster_implied22l(
    Lp = Lp, Mu.W = Mu.W, Mu.B = Mu.B,
    Sigma.W = Sigma.W, Sigma.B = Sigma.B
  )
  mu.y <- out$mu.y
  mu.z <- out$mu.z
  sigma.w <- out$sigma.w
  sigma.b <- out$sigma.b
  sigma.zz <- out$sigma.zz
  sigma.yz <- out$sigma.yz

  # Lp
  nclusters <- Lp$nclusters[[2]]
  cluster.size <- Lp$cluster.size[[2]]
  cluster.sizes <- Lp$cluster.sizes[[2]]
  cluster.idx <- Lp$cluster.idx[[2]]
  between.idx <- Lp$between.idx[[2]]
  ncluster.sizes <- Lp$ncluster.sizes[[2]]
  cluster.size.ns <- Lp$cluster.size.ns[[2]]

  # Y1
  if (length(between.idx) > 0L) {
    S.PW <- YLp[[2]]$Sigma.W[-between.idx, -between.idx, drop = FALSE]
  } else {
    S.PW <- YLp[[2]]$Sigma.W
  }

  # Y2
  cov.d <- YLp[[2]]$cov.d
  mean.d <- YLp[[2]]$mean.d

  # common parts:
  sigma.w.inv <- lav_matrix_symmetric_inverse(
    S = sigma.w,
    logdet = FALSE, Sinv.method = Sinv.method
  )

  # both level-1 and level-2
  G.muy <- matrix(0, ncluster.sizes, length(mu.y))
  G.Sigma.w <- matrix(0, ncluster.sizes, length(lav_matrix_vech(sigma.w)))
  G.Sigma.b <- matrix(0, ncluster.sizes, length(lav_matrix_vech(sigma.b)))

  if (length(between.idx) > 0L) {
    G.muz <- matrix(0, ncluster.sizes, length(mu.z))
    G.Sigma.zz <- matrix(
      0, ncluster.sizes,
      length(lav_matrix_vech(sigma.zz))
    )
    G.Sigma.yz <- matrix(0, ncluster.sizes, length(lav_matrix_vec(sigma.yz)))

    sigma.zz.inv <- lav_matrix_symmetric_inverse(
      S = sigma.zz,
      logdet = FALSE, Sinv.method = Sinv.method
    )
    sigma.yz.zi <- sigma.yz %*% sigma.zz.inv
    sigma.zi.zy <- t(sigma.yz.zi)
    sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy


    for (clz in seq_len(ncluster.sizes)) {
      # cluster size
      nj <- cluster.sizes[clz]

      # level-2 vectors
      b.idx <- seq_len(length(Lp$between.idx[[2]]))
      zyc <- mean.d[[clz]] - c(mu.z, mu.y)
      yc <- zyc[-b.idx]
      zc <- zyc[b.idx]

      # level-2 crossproducts
      Y2Yc <- (cov.d[[clz]] + tcrossprod(mean.d[[clz]] - c(mu.z, mu.y)))
      b.idx <- seq_len(length(Lp$between.idx[[2]]))
      Y2Yc.zz <- Y2Yc[b.idx, b.idx, drop = FALSE]
      Y2Yc.yz <- Y2Yc[-b.idx, b.idx, drop = FALSE]
      Y2Yc.yy <- Y2Yc[-b.idx, -b.idx, drop = FALSE]

      # construct sigma.j
      sigma.j <- (nj * sigma.b.z) + sigma.w
      sigma.j.inv <- lav_matrix_symmetric_inverse(
        S = sigma.j,
        logdet = FALSE, Sinv.method = Sinv.method
      )
      sigma.ji.yz.zi <- sigma.j.inv %*% sigma.yz.zi
      sigma.zi.zy.ji <- t(sigma.ji.yz.zi)

      # common parts
      jYZj <- nj * (sigma.j.inv %*%
        (sigma.yz.zi %*% Y2Yc.zz %*% t(sigma.yz.zi)
          - Y2Yc.yz %*% t(sigma.yz.zi)
          - t(Y2Yc.yz %*% t(sigma.yz.zi)) + Y2Yc.yy)
        %*% sigma.j.inv)

      Z1 <- Y2Yc.zz %*% t(sigma.ji.yz.zi) %*% sigma.yz
      YZ1 <- t(Y2Yc.yz) %*% sigma.j.inv %*% sigma.yz


      # Mu.Z
      G.muz[clz, ] <- -2 * as.numeric(
        (sigma.zz.inv + nj * (sigma.zi.zy.ji %*% sigma.yz.zi)) %*% zc
          - nj * sigma.zi.zy.ji %*% yc
      )

      # MU.Y
      G.muy[clz, ] <- 2 * nj * as.numeric(zc %*% sigma.zi.zy.ji -
        yc %*% sigma.j.inv)

      # SIGMA.W (between part)
      g.sigma.w <- sigma.j.inv - jYZj
      tmp <- g.sigma.w * 2
      diag(tmp) <- diag(g.sigma.w)
      G.Sigma.w[clz, ] <- lav_matrix_vech(tmp)

      # SIGMA.B
      g.sigma.b <- nj * (sigma.j.inv - jYZj)
      tmp <- g.sigma.b * 2
      diag(tmp) <- diag(g.sigma.b)
      G.Sigma.b[clz, ] <- lav_matrix_vech(tmp)

      # SIGMA.ZZ
      g.sigma.zz <- (sigma.zz.inv + nj * sigma.zz.inv %*% (
        t(sigma.yz) %*% (sigma.j.inv - jYZj) %*% sigma.yz
          - (1 / nj * Y2Yc.zz + t(Z1) + Z1 - t(YZ1) - YZ1)) %*%
        sigma.zz.inv)

      tmp <- g.sigma.zz * 2
      diag(tmp) <- diag(g.sigma.zz)
      G.Sigma.zz[clz, ] <- lav_matrix_vech(tmp)

      # SIGMA.ZY
      g.sigma.yz <- 2 * nj * (
        (sigma.j.inv %*%
          (sigma.yz.zi %*% Y2Yc.zz - sigma.yz - Y2Yc.yz)
          + jYZj %*% sigma.yz) %*% sigma.zz.inv)

      G.Sigma.yz[clz, ] <- lav_matrix_vec(g.sigma.yz)
    }

    # level-1
    d.mu.y <- colSums(G.muy * cluster.size.ns)
    d.sigma.w1 <- lav_matrix_vech_reverse(colSums(G.Sigma.w *
      cluster.size.ns))
    d.sigma.b <- lav_matrix_vech_reverse(colSums(G.Sigma.b *
      cluster.size.ns))

    # level-2
    d.mu.z <- colSums(G.muz * cluster.size.ns)
    d.sigma.zz <- lav_matrix_vech_reverse(colSums(G.Sigma.zz *
      cluster.size.ns))
    d.sigma.yz <- matrix(
      colSums(G.Sigma.yz * cluster.size.ns),
      nrow(sigma.yz), ncol(sigma.yz)
    )
  } # between.idx

  else { # no level-2 variables

    for (clz in seq_len(ncluster.sizes)) {
      # cluster size
      nj <- cluster.sizes[clz]

      # level-2 vectors
      yc <- mean.d[[clz]] - mu.y

      # level-2 crossproducts
      Y2Yc.yy <- (cov.d[[clz]] + tcrossprod(mean.d[[clz]] - mu.y))

      # construct sigma.j
      sigma.j <- (nj * sigma.b) + sigma.w
      sigma.j.inv <- lav_matrix_symmetric_inverse(
        S = sigma.j,
        logdet = FALSE, Sinv.method = Sinv.method
      )
      # common part
      jYYj <- nj * sigma.j.inv %*% Y2Yc.yy %*% sigma.j.inv

      # MU.Y
      G.muy[clz, ] <- -2 * nj * as.numeric(yc %*% sigma.j.inv)

      # SIGMA.W (between part)
      g.sigma.w <- sigma.j.inv - jYYj
      tmp <- g.sigma.w * 2
      diag(tmp) <- diag(g.sigma.w)
      G.Sigma.w[clz, ] <- lav_matrix_vech(tmp)

      # SIGMA.B
      g.sigma.b <- nj * (sigma.j.inv - jYYj)
      tmp <- g.sigma.b * 2
      diag(tmp) <- diag(g.sigma.b)
      G.Sigma.b[clz, ] <- lav_matrix_vech(tmp)
    }

    # level-1
    d.mu.y <- colSums(G.muy * cluster.size.ns)
    d.sigma.w1 <- lav_matrix_vech_reverse(colSums(G.Sigma.w *
      cluster.size.ns))
    d.sigma.b <- lav_matrix_vech_reverse(colSums(G.Sigma.b *
      cluster.size.ns))
    # level-2
    d.mu.z <- numeric(0L)
    d.sigma.zz <- matrix(0, 0L, 0L)
    d.sigma.yz <- matrix(0, 0L, 0L)
  }

  # Sigma.W (bis)
  d.sigma.w2 <- (Lp$nclusters[[1]] - nclusters) * (sigma.w.inv
  - sigma.w.inv %*% S.PW %*% sigma.w.inv)
  tmp <- d.sigma.w2 * 2
  diag(tmp) <- diag(d.sigma.w2)
  d.sigma.w2 <- tmp

  d.sigma.w <- d.sigma.w1 + d.sigma.w2

  # rearrange
  dout <- lav_mvnorm_cluster_2l2implied(
    Lp = Lp,
    sigma.w = d.sigma.w, sigma.b = d.sigma.b,
    sigma.yz = d.sigma.yz, sigma.zz = d.sigma.zz,
    mu.y = d.mu.y, mu.z = d.mu.z
  )

  if (return.list) {
    out <- dout
  } else {
    out <- c(
      dout$Mu.W, lav_matrix_vech(dout$Sigma.W),
      dout$Mu.B, lav_matrix_vech(dout$Sigma.B)
    )
  }

  out
}

# cluster-wise scores -2*logl wrt Mu.W, Mu.B, Sigma.W, Sigma.B
lav_mvnorm_cluster_scores_2l <- function(Y1 = NULL,
                                         YLp = NULL,
                                         Lp = NULL,
                                         Mu.W = NULL,
                                         Sigma.W = NULL,
                                         Mu.B = NULL,
                                         Sigma.B = NULL,
                                         Sinv.method = "eigen") {
  # map implied to 2l matrices
  out <- lav_mvnorm_cluster_implied22l(
    Lp = Lp, Mu.W = Mu.W, Mu.B = Mu.B,
    Sigma.W = Sigma.W, Sigma.B = Sigma.B
  )
  mu.y <- out$mu.y
  mu.z <- out$mu.z
  sigma.w <- out$sigma.w
  sigma.b <- out$sigma.b
  sigma.zz <- out$sigma.zz
  sigma.yz <- out$sigma.yz

  # Lp
  nclusters <- Lp$nclusters[[2]]
  cluster.size <- Lp$cluster.size[[2]]
  cluster.idx <- Lp$cluster.idx[[2]]
  between.idx <- Lp$between.idx[[2]]

  # Y1
  if (length(between.idx) > 0L) {
    Y1w <- Y1[, -Lp$between.idx[[2]], drop = FALSE]
  } else {
    Y1w <- Y1
  }
  Y1w.cm <- t(t(Y1w) - mu.y)

  # Y2
  Y2 <- YLp[[2]]$Y2
  # NOTE: ORDER mu.b must match Y2
  mu.b <- numeric(ncol(Y2))
  if (length(between.idx) > 0L) {
    mu.b[-Lp$between.idx[[2]]] <- mu.y
    mu.b[Lp$between.idx[[2]]] <- mu.z
  } else {
    mu.b <- mu.y
  }
  Y2.cm <- t(t(Y2) - mu.b)

  # common parts:
  sigma.w.inv <- lav_matrix_symmetric_inverse(
    S = sigma.w,
    logdet = FALSE, Sinv.method = Sinv.method
  )

  # both level-1 and level-2
  G.muy <- matrix(0, nclusters, length(mu.y))
  G.Sigma.w <- matrix(0, nclusters, length(lav_matrix_vech(sigma.w)))
  G.Sigma.b <- matrix(0, nclusters, length(lav_matrix_vech(sigma.b)))
  G.muz <- matrix(0, nclusters, length(mu.z))
  G.Sigma.zz <- matrix(0, nclusters, length(lav_matrix_vech(sigma.zz)))
  G.Sigma.yz <- matrix(0, nclusters, length(lav_matrix_vec(sigma.yz)))

  if (length(between.idx) > 0L) {
    sigma.zz.inv <- lav_matrix_symmetric_inverse(
      S = sigma.zz,
      logdet = FALSE, Sinv.method = Sinv.method
    )
    sigma.yz.zi <- sigma.yz %*% sigma.zz.inv
    sigma.zi.zy <- t(sigma.yz.zi)
    sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy


    for (cl in seq_len(nclusters)) {
      # cluster size
      nj <- cluster.size[cl]

      # data within for the cluster (centered by mu.y)
      Y1m <- Y1w.cm[cluster.idx == cl, , drop = FALSE]
      yc <- Y2.cm[cl, -Lp$between.idx[[2]]]
      zc <- Y2.cm[cl, Lp$between.idx[[2]]]

      # data between
      Y2Yc <- tcrossprod(Y2.cm[cl, ])
      Y2Yc.zz <- Y2Yc[Lp$between.idx[[2]],
        Lp$between.idx[[2]],
        drop = FALSE
      ]
      Y2Yc.yz <- Y2Yc[-Lp$between.idx[[2]],
        Lp$between.idx[[2]],
        drop = FALSE
      ]
      Y2Yc.yy <- Y2Yc[-Lp$between.idx[[2]],
        -Lp$between.idx[[2]],
        drop = FALSE
      ]

      # construct sigma.j
      sigma.j <- (nj * sigma.b.z) + sigma.w
      sigma.j.inv <- lav_matrix_symmetric_inverse(
        S = sigma.j,
        logdet = FALSE, Sinv.method = Sinv.method
      )
      sigma.ji.yz.zi <- sigma.j.inv %*% sigma.yz.zi
      sigma.zi.zy.ji <- t(sigma.ji.yz.zi)

      # common parts
      jYZj <- nj * (sigma.j.inv %*%
        (sigma.yz.zi %*% Y2Yc.zz %*% t(sigma.yz.zi)
          - Y2Yc.yz %*% t(sigma.yz.zi)
          - t(Y2Yc.yz %*% t(sigma.yz.zi)) + Y2Yc.yy)
        %*% sigma.j.inv)

      Z1 <- Y2Yc.zz %*% t(sigma.ji.yz.zi) %*% sigma.yz
      YZ1 <- t(Y2Yc.yz) %*% sigma.j.inv %*% sigma.yz


      # Mu.Z
      G.muz[cl, ] <- -2 * as.numeric(
        (sigma.zz.inv + nj * (sigma.zi.zy.ji %*% sigma.yz.zi)) %*% zc
          - nj * sigma.zi.zy.ji %*% yc
      )

      # MU.Y
      G.muy[cl, ] <- 2 * nj * as.numeric(zc %*% sigma.zi.zy.ji -
        yc %*% sigma.j.inv)

      # SIGMA.W
      g.sigma.w <- ((nj - 1) * sigma.w.inv
        - sigma.w.inv %*% (crossprod(Y1m) - nj * Y2Yc.yy) %*% sigma.w.inv
        + sigma.j.inv - jYZj)

      tmp <- g.sigma.w * 2
      diag(tmp) <- diag(g.sigma.w)
      G.Sigma.w[cl, ] <- lav_matrix_vech(tmp)

      # SIGMA.B
      g.sigma.b <- nj * (sigma.j.inv - jYZj)

      tmp <- g.sigma.b * 2
      diag(tmp) <- diag(g.sigma.b)
      G.Sigma.b[cl, ] <- lav_matrix_vech(tmp)


      # SIGMA.ZZ
      g.sigma.zz <- (sigma.zz.inv + nj * sigma.zz.inv %*% (
        t(sigma.yz) %*% (sigma.j.inv - jYZj) %*% sigma.yz
          - (1 / nj * Y2Yc.zz + t(Z1) + Z1 - t(YZ1) - YZ1)) %*%
        sigma.zz.inv)

      tmp <- g.sigma.zz * 2
      diag(tmp) <- diag(g.sigma.zz)
      G.Sigma.zz[cl, ] <- lav_matrix_vech(tmp)

      # SIGMA.ZY
      g.sigma.yz <- 2 * nj * (
        (sigma.j.inv %*%
          (sigma.yz.zi %*% Y2Yc.zz - sigma.yz - Y2Yc.yz)
          + jYZj %*% sigma.yz) %*% sigma.zz.inv)

      G.Sigma.yz[cl, ] <- lav_matrix_vec(g.sigma.yz)
    }
  } # between.idx

  else { # no level-2 variables

    for (cl in seq_len(nclusters)) {
      # cluster size
      nj <- cluster.size[cl]

      # data within for the cluster (centered by mu.y)
      Y1m <- Y1w.cm[cluster.idx == cl, , drop = FALSE]
      yc <- Y2.cm[cl, ]

      # data between
      Y2Yc.yy <- tcrossprod(Y2.cm[cl, ])

      # construct sigma.j
      sigma.j <- (nj * sigma.b) + sigma.w
      sigma.j.inv <- lav_matrix_symmetric_inverse(
        S = sigma.j,
        logdet = FALSE, Sinv.method = Sinv.method
      )
      # common part
      jYYj <- nj * sigma.j.inv %*% Y2Yc.yy %*% sigma.j.inv

      # MU.Y
      G.muy[cl, ] <- -2 * nj * as.numeric(yc %*% sigma.j.inv)

      # SIGMA.W
      g.sigma.w <- ((nj - 1) * sigma.w.inv
        - sigma.w.inv %*% (crossprod(Y1m) - nj * Y2Yc.yy) %*% sigma.w.inv
        + sigma.j.inv - jYYj)
      tmp <- g.sigma.w * 2
      diag(tmp) <- diag(g.sigma.w)
      G.Sigma.w[cl, ] <- lav_matrix_vech(tmp)

      # SIGMA.B
      g.sigma.b <- nj * (sigma.j.inv - jYYj)
      tmp <- g.sigma.b * 2
      diag(tmp) <- diag(g.sigma.b)
      G.Sigma.b[cl, ] <- lav_matrix_vech(tmp)
    }
  }

  # rearrange columns to Mu.W, Mu.B, Sigma.W, Sigma.B
  ov.idx <- Lp$ov.idx
  p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]])))

  # Mu.W (for within-only)
  Mu.W.tilde <- matrix(0, nclusters, p.tilde)
  Mu.W.tilde[, ov.idx[[1]]] <- G.muy
  Mu.W.tilde[, Lp$both.idx[[2]]] <- 0 # ZERO!!!
  Mu.W <- Mu.W.tilde[, ov.idx[[1]], drop = FALSE]

  # Mu.B
  Mu.B.tilde <- matrix(0, nclusters, p.tilde)
  Mu.B.tilde[, ov.idx[[1]]] <- G.muy
  if (length(between.idx) > 0L) {
    Mu.B.tilde[, between.idx] <- G.muz
  }
  Mu.B <- Mu.B.tilde[, ov.idx[[2]], drop = FALSE]

  # Sigma.W
  Sigma.W <- G.Sigma.w

  # Sigma.B
  if (length(between.idx) > 0L) {
    p.tilde.star <- p.tilde * (p.tilde + 1) / 2
    B.tilde <- lav_matrix_vech_reverse(seq_len(p.tilde.star))

    Sigma.B.tilde <- matrix(0, nclusters, p.tilde.star)

    col.idx <- lav_matrix_vech(B.tilde[ov.idx[[1]], ov.idx[[1]],
      drop = FALSE
    ])
    Sigma.B.tilde[, col.idx] <- G.Sigma.b

    col.idx <- lav_matrix_vec(B.tilde[ov.idx[[1]], between.idx,
      drop = FALSE
    ])
    Sigma.B.tilde[, col.idx] <- G.Sigma.yz

    col.idx <- lav_matrix_vech(B.tilde[between.idx, between.idx,
      drop = FALSE
    ])
    Sigma.B.tilde[, col.idx] <- G.Sigma.zz

    col.idx <- lav_matrix_vech(B.tilde[ov.idx[[2]], ov.idx[[2]],
      drop = FALSE
    ])
    Sigma.B <- Sigma.B.tilde[, col.idx, drop = FALSE]
  } else {
    p.tilde.star <- p.tilde * (p.tilde + 1) / 2
    B.tilde <- lav_matrix_vech_reverse(seq_len(p.tilde.star))

    Sigma.B.tilde <- matrix(0, nclusters, p.tilde.star)

    col.idx <- lav_matrix_vech(B.tilde[ov.idx[[1]], ov.idx[[1]],
      drop = FALSE
    ])
    Sigma.B.tilde[, col.idx] <- G.Sigma.b

    col.idx <- lav_matrix_vech(B.tilde[ov.idx[[2]], ov.idx[[2]],
      drop = FALSE
    ])
    Sigma.B <- Sigma.B.tilde[, col.idx, drop = FALSE]
    # Sigma.B <- G.Sigma.b
  }

  SCORES <- cbind(Mu.W, Sigma.W, Mu.B, Sigma.B)

  SCORES
}


# first-order information: outer crossprod of scores per cluster
lav_mvnorm_cluster_information_firstorder <- function(Y1 = NULL,
                                                      YLp = NULL,
                                                      Lp = NULL,
                                                      Mu.W = NULL,
                                                      Sigma.W = NULL,
                                                      Mu.B = NULL,
                                                      Sigma.B = NULL,
                                                      x.idx = NULL,
                                                      divide.by.two = FALSE,
                                                      Sinv.method = "eigen") {
  N <- NROW(Y1)

  SCORES <- lav_mvnorm_cluster_scores_2l(
    Y1 = Y1,
    YLp = YLp,
    Lp = Lp,
    Mu.W = Mu.W,
    Sigma.W = Sigma.W,
    Mu.B = Mu.B,
    Sigma.B = Sigma.B,
    Sinv.method = Sinv.method
  )

  # divide by 2 (if we want scores wrt objective function)
  if (divide.by.two) {
    SCORES <- SCORES / 2
  }

  # unit information
  information <- crossprod(SCORES) / Lp$nclusters[[2]]

  # if x.idx, set rows/cols to zero
  if (length(x.idx) > 0L) {
    nw <- length(as.vector(Mu.W))
    nw.star <- nw * (nw + 1) / 2
    nb <- length(as.vector(Mu.B))
    ov.idx <- Lp$ov.idx

    x.idx.w <- which(ov.idx[[1]] %in% x.idx)
    if (length(x.idx.w) > 0L) {
      xw.idx <- c(
        x.idx.w,
        nw + lav_matrix_vech_which_idx(n = nw, idx = x.idx.w)
      )
    } else {
      xw.idx <- integer(0L)
    }
    x.idx.b <- which(ov.idx[[2]] %in% x.idx)
    if (length(x.idx.b) > 0L) {
      xb.idx <- c(
        x.idx.b,
        nb + lav_matrix_vech_which_idx(n = nb, idx = x.idx.b)
      )
    } else {
      xb.idx <- integer(0L)
    }

    all.idx <- c(xw.idx, nw + nw.star + xb.idx)

    information[all.idx, ] <- 0
    information[, all.idx] <- 0
  }

  information
}

# expected information 'h1' model
# order: mu.w within, vech(sigma.w) within, mu.b between, vech(sigma.b) between
# mu.w rows/cols that are splitted within/between are forced to zero
lav_mvnorm_cluster_information_expected <- function(Lp = NULL,
                                                    Mu.W = NULL,
                                                    Sigma.W = NULL,
                                                    Mu.B = NULL,
                                                    Sigma.B = NULL,
                                                    x.idx = integer(0L),
                                                    Sinv.method = "eigen") {
  # translate to internal matrices
  out <- lav_mvnorm_cluster_implied22l(
    Lp = Lp,
    Mu.W = Mu.W, Mu.B = Mu.B,
    Sigma.W = Sigma.W, Sigma.B = Sigma.B
  )
  mu.y <- out$mu.y
  mu.z <- out$mu.z
  sigma.w <- out$sigma.w
  sigma.b <- out$sigma.b
  sigma.zz <- out$sigma.zz
  sigma.yz <- out$sigma.yz

  # create Delta.W.tilde, Delta.B.tilde
  ov.idx <- Lp$ov.idx
  nw <- length(ov.idx[[1]])
  nb <- length(ov.idx[[2]])
  p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]])))
  p.tilde.star <- p.tilde * (p.tilde + 1) / 2
  npar <- p.tilde + p.tilde.star
  B.tilde <- lav_matrix_vech_reverse(seq_len(p.tilde.star))
  w.idx <- lav_matrix_vech(B.tilde[ov.idx[[1]], ov.idx[[1]], drop = FALSE])
  b.idx <- lav_matrix_vech(B.tilde[ov.idx[[2]], ov.idx[[2]], drop = FALSE])

  Delta.W.tilde <- matrix(0, npar, npar)
  Delta.B.tilde <- matrix(0, npar, npar)
  Delta.W.tilde[
    c(ov.idx[[1]], w.idx + p.tilde),
    c(ov.idx[[1]], w.idx + p.tilde)
  ] <- diag(nw + nw * (nw + 1) / 2)
  Delta.B.tilde[
    c(ov.idx[[2]], b.idx + p.tilde),
    c(ov.idx[[2]], b.idx + p.tilde)
  ] <- diag(nb + nb * (nb + 1) / 2)
  Delta.W.tilde <- cbind(Delta.W.tilde, matrix(0, npar, npar))
  Delta.B.tilde <- cbind(matrix(0, npar, npar), Delta.B.tilde)

  nobs <- Lp$nclusters[[1]]
  nclusters <- Lp$nclusters[[2]]
  cluster.size <- Lp$cluster.size[[2]]
  cluster.sizes <- Lp$cluster.sizes[[2]]
  ncluster.sizes <- Lp$ncluster.sizes[[2]]
  n.s <- Lp$cluster.size.ns[[2]]
  between.idx <- Lp$between.idx[[2]]

  information.j <- matrix(0, npar * 2, npar * 2)
  for (clz in seq_len(ncluster.sizes)) {
    # cluster size
    nj <- cluster.sizes[clz]

    # Delta.j -- changes per cluster(size)
    # this is why we can not write info = t(delta) info.sat delta
    Delta.j <- Delta.B.tilde + 1 / nj * Delta.W.tilde

    # compute Sigma.j
    sigma.j <- sigma.w + nj * sigma.b
    if (length(between.idx) > 0L) {
      omega.j <- matrix(0, p.tilde, p.tilde)
      omega.j[-between.idx, -between.idx] <- 1 / nj * sigma.j
      omega.j[-between.idx, between.idx] <- sigma.yz
      omega.j[between.idx, -between.idx] <- t(sigma.yz)
      omega.j[between.idx, between.idx] <- sigma.zz
      # omega.j <- rbind( cbind(sigma.zz, t(sigma.yz)),
      #                  cbind(sigma.yz, 1/nj * sigma.j) )
    } else {
      omega.j <- 1 / nj * sigma.j
    }
    omega.j.inv <- solve(omega.j)

    I11.j <- omega.j.inv
    # if (lav_use_lavaanC()) {
    #   I22.j <- lavaanC::m_kronecker_dup_pre_post(omega.j.inv, multiplicator = 0.5)
    # } else {
      I22.j <- 0.5 * lav_matrix_duplication_pre_post(omega.j.inv %x% omega.j.inv)
    # }
    I.j <- lav_matrix_bdiag(I11.j, I22.j)
    info.j <- t(Delta.j) %*% I.j %*% Delta.j

    information.j <- information.j + n.s[clz] * info.j
  }

  Sigma.W.inv <- lav_matrix_symmetric_inverse(
    S = Sigma.W, logdet = FALSE,
    Sinv.method = Sinv.method
  )
  # create Sigma.W.inv.tilde
  Sigma.W.inv.tilde <- matrix(0, p.tilde, p.tilde)
  Sigma.W.inv.tilde[ov.idx[[1]], ov.idx[[1]]] <- Sigma.W.inv

  I11.w <- Sigma.W.inv.tilde
  # if (lav_use_lavaanC()) {
  #   I22.W <- lavaanC::m_kronecker_dup_pre_post(Sigma.W.inv.tilde, multiplicator = 0.5)
  # } else {
    I22.w <- 0.5 * lav_matrix_duplication_pre_post(Sigma.W.inv.tilde %x% Sigma.W.inv.tilde)
  # }
  I.w <- lav_matrix_bdiag(I11.w, I22.w)
  information.w <- (nobs - nclusters) *
    (t(Delta.W.tilde) %*% I.w %*% Delta.W.tilde)

  # unit information
  information.tilde <- 1 / Lp$nclusters[[2]] * (information.w + information.j)

  # force zero for means both.idx in within part
  information.tilde[Lp$both.idx[[2]], ] <- 0
  information.tilde[, Lp$both.idx[[2]]] <- 0

  # if x.idx, set rows/cols to zero
  if (length(x.idx) > 0L) {
    xw.idx <- c(
      x.idx,
      p.tilde + lav_matrix_vech_which_idx(n = p.tilde, idx = x.idx)
    )
    xb.idx <- npar + xw.idx
    all.idx <- c(xw.idx, xb.idx)
    information.tilde[all.idx, ] <- 0
    information.tilde[, all.idx] <- 0
  }

  # remove redundant rows/cols
  ok.idx <- c(
    ov.idx[[1]],
    w.idx + p.tilde,
    npar + ov.idx[[2]],
    npar + b.idx + p.tilde
  )

  information <- information.tilde[ok.idx, ok.idx]

  information
}


# expected information -- delta
# for non-saturated models only
lav_mvnorm_cluster_information_expected_delta <- function(Lp = NULL,
                                                          Delta = NULL,
                                                          Mu.W = NULL,
                                                          Sigma.W = NULL,
                                                          Mu.B = NULL,
                                                          Sigma.B = NULL,
                                                          Sinv.method = "eigen") {
  # translate to internal matrices
  out <- lav_mvnorm_cluster_implied22l(
    Lp = Lp,
    Mu.W = Mu.W, Mu.B = Mu.B,
    Sigma.W = Sigma.W, Sigma.B = Sigma.B
  )
  mu.y <- out$mu.y
  mu.z <- out$mu.z
  sigma.w <- out$sigma.w
  sigma.b <- out$sigma.b
  sigma.zz <- out$sigma.zz
  sigma.yz <- out$sigma.yz

  # Delta -- this group
  npar <- NCOL(Delta)

  # create Delta.W.tilde, Delta.B.tilde
  ov.idx <- Lp$ov.idx
  nw <- length(ov.idx[[1]])
  nw.star <- nw * (nw + 1) / 2
  nb <- length(ov.idx[[2]])

  Delta.W <- Delta[1:(nw + nw.star), , drop = FALSE]
  Delta.B <- Delta[-(1:(nw + nw.star)), , drop = FALSE]

  p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]])))
  p.tilde.star <- p.tilde * (p.tilde + 1) / 2
  Delta.W.tilde.Mu <- matrix(0, p.tilde, npar)
  Delta.W.tilde.Sigma <- matrix(0, p.tilde.star, npar)
  Delta.B.tilde.Mu <- matrix(0, p.tilde, npar)
  Delta.B.tilde.Sigma <- matrix(0, p.tilde.star, npar)

  Delta.W.tilde.Mu[ov.idx[[1]], ] <- Delta.W[1:nw, ]
  Delta.B.tilde.Mu[ov.idx[[2]], ] <- Delta.B[1:nb, ]

  # correct Delta to reflect Mu.W[ both.idx ] is added to Mu.B[ both.idx ]
  # changed in 0.6-5
  Delta.B.tilde.Mu[Lp$both.idx[[2]], ] <-
    (Delta.B.tilde.Mu[Lp$both.idx[[2]], ] +
      Delta.W.tilde.Mu[Lp$both.idx[[2]], ])
  Delta.W.tilde.Mu[Lp$both.idx[[2]], ] <- 0


  B.tilde <- lav_matrix_vech_reverse(seq_len(p.tilde.star))
  w.idx <- lav_matrix_vech(B.tilde[ov.idx[[1]], ov.idx[[1]], drop = FALSE])
  b.idx <- lav_matrix_vech(B.tilde[ov.idx[[2]], ov.idx[[2]], drop = FALSE])
  Delta.W.tilde.Sigma[w.idx, ] <- Delta.W[-(1:nw), ]
  Delta.B.tilde.Sigma[b.idx, ] <- Delta.B[-(1:nb), ]

  Delta.W.tilde <- rbind(Delta.W.tilde.Mu, Delta.W.tilde.Sigma)
  Delta.B.tilde <- rbind(Delta.B.tilde.Mu, Delta.B.tilde.Sigma)

  nobs <- Lp$nclusters[[1]]
  nclusters <- Lp$nclusters[[2]]
  cluster.size <- Lp$cluster.size[[2]]
  cluster.sizes <- Lp$cluster.sizes[[2]]
  ncluster.sizes <- Lp$ncluster.sizes[[2]]
  n.s <- Lp$cluster.size.ns[[2]]
  between.idx <- Lp$between.idx[[2]]

  information.j <- matrix(0, npar, npar)
  for (clz in seq_len(ncluster.sizes)) {
    # cluster size
    nj <- cluster.sizes[clz]

    # Delta.j -- changes per cluster(size)
    # this is why we can not write info = t(delta) info.sat delta
    Delta.j <- Delta.B.tilde + 1 / nj * Delta.W.tilde

    # compute Sigma.j
    sigma.j <- sigma.w + nj * sigma.b
    if (length(between.idx) > 0L) {
      omega.j <- matrix(0, p.tilde, p.tilde)
      omega.j[-between.idx, -between.idx] <- 1 / nj * sigma.j
      omega.j[-between.idx, between.idx] <- sigma.yz
      omega.j[between.idx, -between.idx] <- t(sigma.yz)
      omega.j[between.idx, between.idx] <- sigma.zz
      # omega.j <- rbind( cbind(sigma.zz, t(sigma.yz)),
      #                  cbind(sigma.yz, 1/nj * sigma.j) )
    } else {
      omega.j <- 1 / nj * sigma.j
    }
    omega.j.inv <- solve(omega.j)

    I11.j <- omega.j.inv
    # if (lav_use_lavaanC()) {
    #   I22.j <- lavaanC::m_kronecker_dup_pre_post(omega.j.inv, multiplicator = 0.5)
    # } else {
      I22.j <- 0.5 * lav_matrix_duplication_pre_post(omega.j.inv %x% omega.j.inv)
    # }
    I.j <- lav_matrix_bdiag(I11.j, I22.j)
    info.j <- t(Delta.j) %*% I.j %*% Delta.j

    information.j <- information.j + n.s[clz] * info.j
  }


  Sigma.W.inv <- lav_matrix_symmetric_inverse(
    S = sigma.w, logdet = FALSE,
    Sinv.method = Sinv.method
  )
  I11.w <- Sigma.W.inv
  # if (lav_use_lavaanC()) {
  #   I22.w <- lavaanC::m_kronecker_dup_pre_post(Sigma.W.inv, multiplicator = 0.5)
  # } else {
    I22.w <- 0.5 * lav_matrix_duplication_pre_post(Sigma.W.inv %x% Sigma.W.inv)
  # }
  I.w <- lav_matrix_bdiag(I11.w, I22.w)

  # force zero for means both.idx in within part
  # changed in 0.6-5
  I.w[Lp$both.idx[[2]], ] <- 0
  I.w[, Lp$both.idx[[2]]] <- 0

  information.w <- (nobs - nclusters) * (t(Delta.W) %*% I.w %*% Delta.W)

  # unit information
  information <- 1 / Lp$nclusters[[2]] * (information.w + information.j)


  information
}


# observed information
# order: mu.w within, vech(sigma.w) within, mu.b between, vech(sigma.b) between
# mu.w rows/cols that are splitted within/between are forced to zero
#
# numerical approximation (for now)
lav_mvnorm_cluster_information_observed <- function(Lp = NULL,
                                                    YLp = NULL,
                                                    Mu.W = NULL,
                                                    Sigma.W = NULL,
                                                    Mu.B = NULL,
                                                    Sigma.B = NULL,
                                                    x.idx = integer(0L),
                                                    Sinv.method = "eigen") {
  nobs <- Lp$nclusters[[1]]

  nw <- length(as.vector(Mu.W))
  nw.star <- nw * (nw + 1) / 2
  nb <- length(as.vector(Mu.B))
  nb.star <- nb * (nb + 1) / 2

  ov.idx <- Lp$ov.idx
  p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]])))

  # Mu.W (for within-only)
  Mu.W.tilde <- numeric(p.tilde)
  Mu.W.tilde[ov.idx[[1]]] <- Mu.W

  # local function -- gradient
  GRAD <- function(x) {
    # Mu.W (for within-only)
    Mu.W.tilde2 <- numeric(p.tilde)
    Mu.W.tilde2[ov.idx[[1]]] <- x[1:nw]
    Mu.W.tilde2[Lp$both.idx[[2]]] <- Mu.W.tilde[Lp$both.idx[[2]]]
    Mu.W2 <- Mu.W.tilde2[ov.idx[[1]]]

    Sigma.W2 <- lav_matrix_vech_reverse(x[nw + 1:nw.star])
    Mu.B2 <- x[nw + nw.star + 1:nb]
    Sigma.B2 <- lav_matrix_vech_reverse(x[nw + nw.star + nb + 1:nb.star])

    dx <- lav_mvnorm_cluster_dlogl_2l_samplestats(
      YLp = YLp,
      Lp = Lp, Mu.W = Mu.W2, Sigma.W = Sigma.W2,
      Mu.B = Mu.B2, Sigma.B = Sigma.B2,
      return.list = FALSE,
      Sinv.method = Sinv.method
    )

    # dx is for -2*logl
    -1 / 2 * dx
  }

  # start.x
  start.x <- c(
    as.vector(Mu.W), lav_matrix_vech(Sigma.W),
    as.vector(Mu.B), lav_matrix_vech(Sigma.B)
  )

  # total information
  information <- -1 * numDeriv::jacobian(func = GRAD, x = start.x)

  # unit information
  information <- information / Lp$nclusters[[2]]

  # if x.idx, set rows/cols to zero
  if (length(x.idx) > 0L) {
    x.idx.w <- which(ov.idx[[1]] %in% x.idx)
    if (length(x.idx.w) > 0L) {
      xw.idx <- c(
        x.idx.w,
        nw + lav_matrix_vech_which_idx(n = nw, idx = x.idx.w)
      )
    } else {
      xw.idx <- integer(0L)
    }
    x.idx.b <- which(ov.idx[[2]] %in% x.idx)
    if (length(x.idx.b) > 0L) {
      xb.idx <- c(
        x.idx.b,
        nb + lav_matrix_vech_which_idx(n = nb, idx = x.idx.b)
      )
    } else {
      xb.idx <- integer(0L)
    }

    all.idx <- c(xw.idx, nw + nw.star + xb.idx)

    information[all.idx, ] <- 0
    information[, all.idx] <- 0
  }

  information
}

# estimate ML estimates of Mu.W, Mu.B, Sigma.W, Sigma.B
# using the EM algorithm
#
# per cluster-SIZE
#
lav_mvnorm_cluster_em_sat <- function(YLp = NULL,
                                      Lp = NULL,
                                      tol = 1e-04,
                                      max.iter = 5000,
                                      min.variance = 1e-05) {
  # lavdata
  between.idx <- Lp$between.idx[[2]]
  within.idx <- Lp$within.idx[[2]]
  Y2 <- YLp[[2]]$Y2

  # starting values for Sigma
  ov.idx <- Lp$ov.idx
  # COVT <- lavsamplestats@cov[[1]]
  # Sigma.W <- diag( diag(COVT)[ov.idx[[1]]] )
  # Sigma.B <- diag( diag(COVT)[ov.idx[[2]]] )
  Sigma.W <- diag(length(ov.idx[[1]]))
  Sigma.B <- diag(length(ov.idx[[2]]))
  Mu.W <- numeric(length(ov.idx[[1]]))
  Mu.B <- numeric(length(ov.idx[[2]]))
  # Mu.W.tilde <- YLp[[2]]$Mu.W
  # Mu.B.tilde <- YLp[[2]]$Mu.B
  # if(length(between.idx) > 0) {
  #    Mu.W <- Mu.W.tilde[-between.idx]
  # } else {
  #    Mu.W <- Mu.W.tilde
  # }
  # if(length(within.idx) > 0) {
  #    Mu.B <- Mu.B.tilde[-within.idx]
  # } else {
  #    Mu.B <- Mu.B.tilde
  # }

  # report initial fx
  fx <- lav_mvnorm_cluster_loglik_samplestats_2l(
    YLp = YLp, Lp = Lp,
    Mu.W = Mu.W, Sigma.W = Sigma.W,
    Mu.B = Mu.B, Sigma.B = Sigma.B,
    Sinv.method = "eigen", log2pi = TRUE, minus.two = FALSE
  )

  # if verbose, report
  if (lav_verbose()) {
    cat(
      "EM iter:", sprintf("%3d", 0),
      " fx =", sprintf("%17.10f", fx),
      "\n"
    )
  }

  # translate to internal matrices
  out <- lav_mvnorm_cluster_implied22l(
    Lp = Lp,
    Mu.W = Mu.W, Sigma.W = Sigma.W, Mu.B = Mu.B, Sigma.B = Sigma.B
  )
  mu.y <- out$mu.y
  mu.z <- out$mu.z
  mu.w <- out$mu.w
  mu.b <- out$mu.b
  sigma.w <- out$sigma.w
  sigma.b <- out$sigma.b
  sigma.zz <- out$sigma.zz
  sigma.yz <- out$sigma.yz

  # mu.z and sigma.zz can be computed beforehand
  if (length(between.idx) > 0L) {
    Z <- Y2[, between.idx, drop = FALSE]
    mu.z <- colMeans(Z, na.rm = TRUE)
    sigma.zz <- cov(Z, use = "pairwise.complete.obs") * (Lp$nclusters[[2]] - 1L) / Lp$nclusters[[2]]
    # sigma.zz <- 1/Lp$nclusters[[2]] * crossprod(Z) - tcrossprod(mu.z)
    # Y1Y1 <- Y1Y1[-between.idx, -between.idx, drop=FALSE]
  }

  # EM iterations
  fx.old <- fx
  for (i in 1:max.iter) {
    # E-step
    estep <- lav_mvnorm_cluster_em_estepb( # Y1 = Y1,
      YLp = YLp,
      Lp = Lp,
      sigma.w = sigma.w,
      sigma.b = sigma.b,
      mu.w = mu.w,
      mu.b = mu.b,
      sigma.yz = sigma.yz,
      sigma.zz = sigma.zz,
      mu.z = mu.z
    )

    # mstep
    sigma.w <- estep$sigma.w
    sigma.b <- estep$sigma.b
    sigma.yz <- estep$sigma.yz
    mu.w <- estep$mu.w
    mu.b <- estep$mu.b

    implied2 <- lav_mvnorm_cluster_2l2implied(
      Lp = Lp,
      sigma.w = estep$sigma.w, sigma.b = estep$sigma.b,
      sigma.zz = sigma.zz, sigma.yz = estep$sigma.yz,
      mu.z = mu.z,
      mu.y = NULL, mu.w = estep$mu.w, mu.b = estep$mu.b
    )

    # check for (near-zero) variances at the within level, and set
    # them to min.variance
    Sigma.W <- implied2$Sigma.W
    zero.var <- which(diag(Sigma.W) < min.variance)
    if (length(zero.var) > 0L) {
      Sigma.W[, zero.var] <- sigma.w[, zero.var] <- 0
      Sigma.W[zero.var, ] <- sigma.w[zero.var, ] <- 0
      diag(Sigma.W)[zero.var] <- diag(sigma.w)[zero.var] <- min.variance
    }

    fx <- lav_mvnorm_cluster_loglik_samplestats_2l(
      YLp = YLp,
      Lp = Lp, Mu.W = implied2$Mu.W, Sigma.W = Sigma.W,
      Mu.B = implied2$Mu.B, Sigma.B = implied2$Sigma.B,
      Sinv.method = "eigen", log2pi = TRUE, minus.two = FALSE
    )

    # fx.delta
    fx.delta <- fx - fx.old

    # check if fx.delta is finite
    if (!is.finite(fx.delta)) {
      # not good ... something is very wrong; perhaps near-singular
      # matrices?
      cat("\n")
      cat("FATAL problem: dumping Sigma.W and Sigma.B matrices:\n\n")
      cat("Sigma.W:\n")
      print(Sigma.W)
      cat("\n")
      cat("Sigma.B:\n")
      print(implied2$Sigma.B)
      cat("\n")
      lav_msg_stop(gettext(
        "EM steps of the saturated (H1) model failed; some matrices may
         be singular; please check your data for (near-)perfect correlations."))
    }

    # what if fx.delta is negative?
    if (fx.delta < 0) {
      lav_msg_warn(gettext(
        "logl decreased during EM steps of the saturated (H1) model"))
    }

    if (lav_verbose()) {
      cat(
        "EM iter:", sprintf("%3d", i),
        " fx =", sprintf("%17.10f", fx),
        " fx.delta =", sprintf("%9.8f", fx.delta),
        "\n"
      )
    }

    # convergence check
    if (fx.delta < tol) {
      break
    } else {
      fx.old <- fx
    }
  } # EM iterations

  list(
    Sigma.W = implied2$Sigma.W, Sigma.B = implied2$Sigma.B,
    Mu.W = implied2$Mu.W, Mu.B = implied2$Mu.B, logl = fx
  )
}


# based on lav_mvnorm_cluster_em_estep
lav_mvnorm_cluster_em_h0 <- function(lavsamplestats = NULL,
                                     lavdata = NULL,
                                     lavimplied = NULL,
                                     lavpartable = NULL,
                                     lavmodel = NULL,
                                     lavoptions = NULL,
                                     verbose.x = FALSE,
                                     fx.tol = 1e-08,
                                     dx.tol = 1e-05,
                                     max.iter = 5000,
                                     mstep.iter.max = 10000L,
                                     mstep.rel.tol = 1e-10) {
  # single group only for now
  stopifnot(lavdata@ngroups == 1L)

  # lavdata
  Lp <- lavdata@Lp[[1]] # first group only (for now)
  ov.names.l <- lavdata@ov.names.l[[1]] # first group only (for now)
  Y1 <- lavdata@X[[1]] # first group only
  YLp <- lavsamplestats@YLp[[1]] # first group only

  between.idx <- Lp$between.idx[[2]]
  Y2 <- YLp[[2]]$Y2

  # initial values
  x.current <- lav_model_get_parameters(lavmodel)

  # implied
  if (is.null(lavimplied)) {
    lavimplied <- lav_model_implied(lavmodel)
  }

  # TODO: what if current 'starting' parameters imply a non-pd sigma.b?

  # report initial fx
  fx <- lav_mvnorm_cluster_loglik_samplestats_2l(
    YLp = YLp, Lp = Lp,
    Mu.W = lavimplied$mean[[1]], Sigma.W = lavimplied$cov[[1]],
    Mu.B = lavimplied$mean[[2]], Sigma.B = lavimplied$cov[[2]],
    Sinv.method = "eigen", log2pi = TRUE, minus.two = FALSE
  )

  # if verbose, report
  if (lav_verbose()) {
    cat(
      "EM iter:", sprintf("%3d", 0),
      " fx =", sprintf("%17.10f", fx),
      "\n"
    )
  }

  # translate to internal matrices
  out <- lav_mvnorm_cluster_implied22l(
    Lp = Lp,
    Mu.W = lavimplied$mean[[1]], Sigma.W = lavimplied$cov[[1]],
    Mu.B = lavimplied$mean[[2]], Sigma.B = lavimplied$cov[[2]]
  )
  mu.y <- out$mu.y
  mu.z <- out$mu.z
  mu.w <- out$mu.w
  mu.b <- out$mu.b
  sigma.w <- out$sigma.w
  sigma.b <- out$sigma.b
  sigma.zz <- out$sigma.zz
  sigma.yz <- out$sigma.yz

  # mu.z and sigma.zz can be computed beforehand
  if (length(between.idx) > 0L) {
    Z <- Y2[, between.idx, drop = FALSE]
    mu.z <- colMeans(Y2)[between.idx]
    sigma.zz <- cov(Z) * (Lp$nclusters[[2]] - 1L) / Lp$nclusters[[2]]
    # sigma.zz <- 1/Lp$nclusters[[2]] * crossprod(Z) - tcrossprod(mu.z)
    # Y1Y1 <- Y1Y1[-between.idx, -between.idx, drop=FALSE]
  }

  # EM iterations
  fx.old <- fx
  fx2.old <- 0
  REL <- numeric(max.iter)
  for (i in 1:max.iter) {
    # E-step
    estep <- lav_mvnorm_cluster_em_estepb(
      YLp = YLp,
      Lp = Lp,
      sigma.w = sigma.w,
      sigma.b = sigma.b,
      mu.w = mu.w,
      mu.b = mu.b,
      sigma.yz = sigma.yz,
      sigma.zz = sigma.zz,
      mu.z = mu.z
    )

    # back to model-implied dimensions
    implied <- lav_mvnorm_cluster_2l2implied(
      Lp = Lp,
      sigma.w = estep$sigma.w, sigma.b = estep$sigma.b,
      sigma.zz = sigma.zz, sigma.yz = estep$sigma.yz,
      mu.z = mu.z,
      mu.y = NULL, mu.w = estep$mu.w, mu.b = estep$mu.b
    )
    rownames(implied$Sigma.W) <- ov.names.l[[1]]
    rownames(implied$Sigma.B) <- ov.names.l[[2]]

    # M-step

    # fit two-group model
    local.partable <- lavpartable
    # if a group column exists, delete it (it will be overriden anyway)
    local.partable$group <- NULL
    level.idx <- which(names(local.partable) == "level")
    names(local.partable)[level.idx] <- "group"
    local.partable$est <- NULL
    local.partable$se <- NULL

    # give current values as starting values
    free.idx <- which(lavpartable$free > 0L)
    local.partable$ustart[free.idx] <- x.current

    local.fit <- lavaan(local.partable,
      sample.cov = list(
        within = implied$Sigma.W,
        between = implied$Sigma.B
      ),
      sample.mean = list(
        within = implied$Mu.W,
        between = implied$Mu.B
      ),
      sample.nobs = Lp$nclusters,
      sample.cov.rescale = FALSE,
      control = list(
        iter.max = mstep.iter.max,
        rel.tol = mstep.rel.tol
      ),
      fixed.x = any(lavpartable$exo == 1L),
      estimator = "ML",
      warn = FALSE, # no warnings
      check.start = FALSE,
      check.post = FALSE,
      check.gradient = FALSE,
      check.vcov = FALSE,
      baseline = FALSE,
      h1 = FALSE,
      se = "none",
      test = "none"
    )

    # end of M-step

    implied2 <- local.fit@implied
    fx <- lav_mvnorm_cluster_loglik_samplestats_2l(
      YLp = YLp,
      Lp = Lp, Mu.W = implied2$mean[[1]], Sigma.W = implied2$cov[[1]],
      Mu.B = implied2$mean[[2]], Sigma.B = implied2$cov[[2]],
      Sinv.method = "eigen", log2pi = TRUE, minus.two = FALSE
    )

    # fx.delta
    fx.delta <- fx - fx.old

    # derivatives
    lavmodel <- lav_model_set_parameters(lavmodel, x = local.fit@optim$x)
    dx <- lav_model_gradient(lavmodel,
      lavdata = lavdata,
      lavsamplestats = lavsamplestats
    )
    max.dx <- max(abs(dx))

    if (lav_verbose()) {
      cat(
        "EM iter:", sprintf("%3d", i),
        " fx =", sprintf("%17.10f", fx),
        " fx.delta =", sprintf("%9.8f", fx.delta),
        " mstep.iter =", sprintf(
          "%3d",
          lavInspect(local.fit, "iterations")
        ),
        " max.dx = ", sprintf("%9.8f", max.dx),
        "\n"
      )
    }

    # stopping rule check
    if (fx.delta < fx.tol) {
      if (lav_verbose()) {
        cat("EM stopping rule reached: fx.delta < ", fx.tol, "\n")
      }
      break
    } else {
      fx.old <- fx
      x.current <- local.fit@optim$x
      if (verbose.x) {
        print(round(x.current, 3))
      }
    }

    # second stopping rule check -- derivatives
    if (max.dx < dx.tol) {
      if (lav_verbose()) {
        cat("EM stopping rule reached: max.dx < ", dx.tol, "\n")
      }
      break
    }

    # translate to internal matrices
    out <- lav_mvnorm_cluster_implied22l(
      Lp = Lp,
      Mu.W = implied2$mean[[1]], Sigma.W = implied2$cov[[1]],
      Mu.B = implied2$mean[[2]], Sigma.B = implied2$cov[[2]]
    )
    mu.y <- out$mu.y
    mu.z <- out$mu.z
    mu.w <- out$mu.w
    mu.b <- out$mu.b
    sigma.w <- out$sigma.w
    sigma.b <- out$sigma.b
    sigma.zz <- out$sigma.zz
    sigma.yz <- out$sigma.yz
  } # EM iterations

  x <- local.fit@optim$x

  # add attributes
  if (i < max.iter) {
    attr(x, "converged") <- TRUE
    attr(x, "warn.txt") <- ""
  } else {
    attr(x, "converged") <- FALSE
    attr(x, "warn.txt") <- paste("maxmimum number of iterations (",
      max.iter, ") ",
      "was reached without convergence.\n",
      sep = ""
    )
  }
  attr(x, "iterations") <- i
  attr(x, "control") <- list(
    em.iter.max = max.iter,
    em.fx.tol = fx.tol,
    em.dx.tol = dx.tol
  )
  attr(fx, "fx.group") <- fx # single group for now
  attr(x, "fx") <- fx

  x
}

# get the random effects (here: expected values for cluster means)
# and optionally a standard error
lav_mvnorm_cluster_em_estep_ranef <- function(YLp = NULL,
                                              Lp = NULL,
                                              sigma.w = NULL,
                                              sigma.b = NULL,
                                              sigma.yz = NULL,
                                              sigma.zz = NULL,
                                              mu.z = NULL,
                                              mu.w = NULL,
                                              mu.b = NULL,
                                              se = FALSE) {
  # sample stats
  nobs <- Lp$nclusters[[1]]
  nclusters <- Lp$nclusters[[2]]
  cluster.size <- Lp$cluster.size[[2]]
  between.idx <- Lp$between.idx[[2]]

  Y2 <- YLp[[2]]$Y2

  nvar.y <- ncol(sigma.w)
  nvar.z <- ncol(sigma.zz)

  MB.j <- matrix(0, nrow = nclusters, ncol = nvar.y)
  SE.j <- matrix(0, nrow = nclusters, ncol = nvar.y)

  mu.y <- mu.w + mu.b

  if (length(between.idx) > 0L) {
    sigma.1 <- cbind(sigma.yz, sigma.b)
    mu <- c(mu.z, mu.y)
  } else {
    sigma.1 <- sigma.b
    mu <- mu.y
  }

  # E-step
  for (cl in seq_len(nclusters)) {
    nj <- cluster.size[cl]

    # data
    if (length(between.idx) > 0L) {
      # z comes first!
      b.j <- c(
        Y2[cl, between.idx],
        Y2[cl, -between.idx]
      )
      ybar.j <- Y2[cl, -between.idx]
    } else {
      ybar.j <- b.j <- Y2[cl, ]
    }

    sigma.j <- sigma.w + nj * sigma.b
    if (length(between.idx) > 0L) {
      omega.j <- rbind(
        cbind(sigma.zz, t(sigma.yz)),
        cbind(sigma.yz, 1 / nj * sigma.j)
      )
    } else {
      omega.j <- 1 / nj * sigma.j
    }
    omega.j.inv <- solve(omega.j)

    # E(v|y)
    Ev <- as.numeric(mu.b + (sigma.1 %*% omega.j.inv %*% (b.j - mu)))
    MB.j[cl, ] <- Ev

    if (se) {
      # Cov(v|y)
      Covv <- sigma.b - (sigma.1 %*% omega.j.inv %*% t(sigma.1))

      # force symmetry
      Covv <- (Covv + t(Covv)) / 2

      Covv.diag <- diag(Covv)
      nonzero.idx <- which(Covv.diag > 0)

      SE.j[cl, ] <- numeric(length(Covv.diag))
      SE.j[cl, nonzero.idx] <- sqrt(Covv.diag[nonzero.idx])
    }
  }

  if (se) {
    attr(MB.j, "se") <- SE.j
  }

  MB.j
}

# per cluster
lav_mvnorm_cluster_em_estep <- function( # Y1           = NULL,
                                        YLp = NULL,
                                        Lp = NULL,
                                        sigma.w = NULL,
                                        sigma.b = NULL,
                                        sigma.yz = NULL,
                                        sigma.zz = NULL,
                                        mu.z = NULL,
                                        mu.w = NULL,
                                        mu.b = NULL) {
  # sample stats
  nobs <- Lp$nclusters[[1]]
  nclusters <- Lp$nclusters[[2]]
  cluster.size <- Lp$cluster.size[[2]]
  cluster.idx <- Lp$cluster.idx[[2]]
  within.idx <- Lp$within.idx[[2]]
  between.idx <- Lp$between.idx[[2]]
  both.idx <- Lp$both.idx[[2]]

  Y2 <- YLp[[2]]$Y2
  Y1Y1 <- YLp[[2]]$Y1Y1

  nvar.y <- ncol(sigma.w)
  nvar.z <- ncol(sigma.zz)

  CW2.j <- matrix(0, nrow = nvar.y, ncol = nvar.y)
  CB.j <- matrix(0, nrow = nvar.y, ncol = nvar.y)
  MW.j <- matrix(0, nrow = nclusters, ncol = nvar.y)
  MB.j <- matrix(0, nrow = nclusters, ncol = nvar.y)
  ZY.j <- matrix(0, nrow = nvar.z, ncol = nvar.y)

  mu.y <- mu.w + mu.b

  if (length(between.idx) > 0L) {
    sigma.1 <- cbind(sigma.yz, sigma.b)
    mu <- c(mu.z, mu.y)
    Y1Y1 <- Y1Y1[-between.idx, -between.idx, drop = FALSE]
  } else {
    sigma.1 <- sigma.b
    mu <- mu.y
  }

  # E-step
  for (cl in seq_len(nclusters)) {
    nj <- cluster.size[cl]

    # data
    if (length(between.idx) > 0L) {
      # z comes first!
      b.j <- c(
        Y2[cl, between.idx],
        Y2[cl, -between.idx]
      )
      ybar.j <- Y2[cl, -between.idx]
    } else {
      ybar.j <- b.j <- Y2[cl, ]
    }

    sigma.j <- sigma.w + nj * sigma.b
    if (length(between.idx) > 0L) {
      omega.j <- rbind(
        cbind(sigma.zz, t(sigma.yz)),
        cbind(sigma.yz, 1 / nj * sigma.j)
      )
    } else {
      omega.j <- 1 / nj * sigma.j
    }
    omega.j.inv <- solve(omega.j)

    # E(v|y)
    Ev <- as.numeric(mu.b + (sigma.1 %*% omega.j.inv %*% (b.j - mu)))

    # Cov(v|y)
    Covv <- sigma.b - (sigma.1 %*% omega.j.inv %*% t(sigma.1))

    # force symmetry
    Covv <- (Covv + t(Covv)) / 2

    # E(vv|y) = Cov(v|y) + E(v|y)E(v|y)^T
    Evv <- Covv + tcrossprod(Ev)

    # store for this cluster
    MW.j[cl, ] <- ybar.j - Ev
    MB.j[cl, ] <- Ev
    CW2.j <- CW2.j + nj * (Evv - tcrossprod(ybar.j, Ev)
      - tcrossprod(Ev, ybar.j))
    CB.j <- CB.j + Evv

    # between only
    if (length(between.idx) > 0L) {
      ZY.j <- ZY.j + tcrossprod(Y2[cl, between.idx], Ev)
    }
  }

  M.w <- 1 / nobs * colSums(MW.j * cluster.size)
  M.b <- 1 / nclusters * colSums(MB.j)
  C.b <- 1 / nclusters * CB.j
  C.w <- 1 / nobs * (Y1Y1 + CW2.j)
  # end of E-step

  # make symmetric (not needed here?)
  # C.b <- (C.b + t(C.b))/2
  # C.w <- (C.w + t(C.w))/2

  # between only
  if (length(between.idx) > 0L) {
    A <- 1 / nclusters * ZY.j - tcrossprod(mu.z, M.b)
  }

  sigma.w <- C.w - tcrossprod(M.w)
  sigma.b <- C.b - tcrossprod(M.b)
  mu.w <- M.w
  mu.b <- M.b

  if (length(between.idx) > 0L) {
    sigma.yz <- t(A)
  }

  list(
    sigma.w = sigma.w, sigma.b = sigma.b, mu.w = mu.w, mu.b = mu.b,
    sigma.yz = sigma.yz, sigma.zz = sigma.zz, mu.z = mu.z
  )
}

# per cluster SIZE
lav_mvnorm_cluster_em_estepb <- function( # Y1           = NULL, # not used!
                                         YLp = NULL,
                                         Lp = NULL,
                                         sigma.w = NULL,
                                         sigma.b = NULL,
                                         sigma.yz = NULL,
                                         sigma.zz = NULL,
                                         mu.z = NULL,
                                         mu.w = NULL,
                                         mu.b = NULL) {
  # sample stats
  nobs <- Lp$nclusters[[1]]
  nclusters <- Lp$nclusters[[2]]
  cluster.size <- Lp$cluster.size[[2]]
  cluster.idx <- Lp$cluster.idx[[2]]
  between.idx <- Lp$between.idx[[2]]
  cluster.sizes <- Lp$cluster.sizes[[2]]
  ncluster.sizes <- Lp$ncluster.sizes[[2]]
  n.s <- Lp$cluster.size.ns[[2]]

  Y2 <- YLp[[2]]$Y2
  Y1Y1 <- YLp[[2]]$Y1Y1

  nvar.y <- ncol(sigma.w)
  nvar.z <- ncol(sigma.zz)

  mu.y <- mu.w + mu.b

  if (length(between.idx) > 0L) {
    sigma.1 <- cbind(sigma.yz, sigma.b)
    mu <- c(mu.z, mu.y)
    Y1Y1 <- Y1Y1[-between.idx, -between.idx, drop = FALSE]
  } else {
    sigma.1 <- sigma.b
    mu <- mu.y
  }

  # per cluster SIZE
  CW2.s <- matrix(0, nrow = nvar.y, ncol = nvar.y)
  CB.s <- matrix(0, nrow = nvar.y, ncol = nvar.y)
  MW.s <- matrix(0, nrow = ncluster.sizes, ncol = nvar.y)
  MB.s <- matrix(0, nrow = ncluster.sizes, ncol = nvar.y)
  ZY.s <- matrix(0, nvar.z, nvar.y)

  # E-step
  for (clz in seq_len(ncluster.sizes)) {
    # cluster size
    nj <- cluster.sizes[clz]

    # data
    if (length(between.idx) > 0L) {
      # z comes first!
      b.j <- cbind(
        Y2[cluster.size == nj, between.idx, drop = FALSE],
        Y2[cluster.size == nj, -between.idx, drop = FALSE]
      )
      ybar.j <- Y2[cluster.size == nj, -between.idx, drop = FALSE]
    } else {
      ybar.j <- b.j <- Y2[cluster.size == nj, , drop = FALSE]
    }

    sigma.j <- sigma.w + nj * sigma.b
    if (length(between.idx) > 0L) {
      omega.j <- rbind(
        cbind(sigma.zz, t(sigma.yz)),
        cbind(sigma.yz, 1 / nj * sigma.j)
      )
    } else {
      omega.j <- 1 / nj * sigma.j
    }
    omega.j.inv <- solve(omega.j)
    sigma.1.j.inv <- sigma.1 %*% omega.j.inv

    # E(v|y)
    b.jc <- t(t(b.j) - mu)
    tmp <- b.jc %*% t(sigma.1.j.inv)
    Ev <- t(t(tmp) + mu.b)

    # Cov(v|y)
    Covv <- n.s[clz] * (sigma.b - (sigma.1.j.inv %*% t(sigma.1)))

    # force symmetry
    Covv <- (Covv + t(Covv)) / 2

    # E(vv|y) = Cov(v|y) + E(v|y)E(v|y)^T
    Evv <- Covv + crossprod(Ev)

    # store for this cluster SIZE
    MW.s[clz, ] <- nj * colSums(ybar.j - Ev)
    MB.s[clz, ] <- colSums(Ev)
    CW2.s <- CW2.s + nj * (Evv - crossprod(ybar.j, Ev)
      - crossprod(Ev, ybar.j))
    CB.s <- CB.s + Evv

    # between only
    if (length(between.idx) > 0L) {
      ZY.s <- ZY.s + crossprod(Y2[cluster.size == nj, between.idx,
        drop = FALSE
      ], Ev)
    }
  } # cluster-sizes

  M.ws <- 1 / nobs * colSums(MW.s)
  M.bs <- 1 / nclusters * colSums(MB.s)
  C.bs <- 1 / nclusters * CB.s
  C.ws <- 1 / nobs * (Y1Y1 + CW2.s)

  # between only
  if (length(between.idx) > 0L) {
    As <- 1 / nclusters * ZY.s - tcrossprod(mu.z, M.bs)
  }

  sigma.w <- C.ws - tcrossprod(M.ws)
  sigma.b <- C.bs - tcrossprod(M.bs)
  mu.w <- M.ws
  mu.b <- M.bs
  if (length(between.idx) > 0L) {
    sigma.yz <- t(As)
  }

  list(
    sigma.w = sigma.w, sigma.b = sigma.b, mu.w = mu.w, mu.b = mu.b,
    sigma.yz = sigma.yz, sigma.zz = sigma.zz, mu.z = mu.z
  )
}

# print 'blocks' of test statistics
# - blocks with 'scaling.factors' come first (in 'two columns')
# - then come the 'single-column' test statistics (eg browne.residual.adf)
# - print additional informatiation (eg information matrix, h1.information, ...)
#   if they deviate from what is used for the standard errors

# this is used by the summary() function and lavTest(, output = "text")

# YR 13 Feb 2026: if test[[1]] has stat = NA, skip if there are other tests

lav_test_print <- function(object, nd = 3L) {
  # object is list of tests
  TEST <- object

  # empty list?
  if (is.null(TEST) || length(TEST) == 0L || !is.list(TEST)) {
    return(character(0L))
  }

  # test = "none"?
  if (TEST[[1]]$test == "none") {
    return(character(0L))
  }

  # remove empty first test (stat = NA) if multiple tests are available)
  if (length(TEST) > 1L && is.na(TEST[[1]]$stat)) {
    TEST <- TEST[-1]
  }

  # meta data
  info <- attr(object, "info")
  ngroups <- info$ngroups
  group.label <- info$group.label
  information <- info$information
  h1.information <- info$h1.information
  observed.information <- info$observed.information

  # num format
  num.format <- paste("%", max(8L, nd + 5L), ".", nd, "f", sep = "")

  # header
  cat("Model Test User Model:\n")

  # locate 'robust' tests (here: having a scaling factor)
  has.no.scaling <- unname(sapply(
    (lapply(TEST, "[[", "scaling.factor")),
    is.null
  ))
  robust.idx <- which(!has.no.scaling)
  non.robust.idx <- which(has.no.scaling)
  scaled.idx <- 1L
  if (length(robust.idx) > 0L) {
    scaled.idx <- which(names(TEST) == TEST[[robust.idx[1]]]$scaled.test)
    if (length(scaled.idx) == 0L) {
      scaled.idx <- 1L
    }
    # remove 'scaled.test', because it is shown together with robust
    non.robust.idx <- non.robust.idx[-scaled.idx]
  }
  BLOCKS <- c(robust.idx, non.robust.idx)
  nBlocks <- length(BLOCKS)

  # print out blocks
  for (block in BLOCKS) {
    # one or two-columns for this block?
    if (length(robust.idx) > 0L && block %in% robust.idx) {
      twocolumn <- TRUE
    } else {
      twocolumn <- FALSE
    }

    if (!twocolumn) {
      # print label
      c1 <- c2 <- c3 <- character(0L)
      if (!is.null(TEST[[block]]$label)) {
        c1 <- c(c1, TEST[[block]]$label)
        c2 <- c(c2, "")
        c3 <- c(c3, "")
      }
      if (is.na(TEST[[block]]$df) || TEST[[block]]$df == 0L) {
        c1 <- c(c1, c("Test statistic", "Degrees of freedom"))
        c2 <- c(c2, c(
          sprintf(num.format, TEST[[block]]$stat),
          ifelse(TEST[[block]]$df %% 1 == 0, # integer
            TEST[[block]]$df,
            sprintf(num.format, TEST[[block]]$df)
          )
        ))
        c3 <- c(c3, c("", ""))
      } else {
        PLABEL <- "P-value"
        if (!is.null(TEST[[block]]$refdistr)) {
          if (TEST[[block]]$refdistr == "chisq") {
            PLABEL <- "P-value (Chi-square)"
          } else if (TEST[[block]]$refdistr == "unknown") {
            PLABEL <- "P-value (Unknown)"
          } else if (TEST[[block]]$refdistr == "bootstrap") {
            PLABEL <- "P-value (Bollen-Stine bootstrap)"
          }
        }
        c1 <- c(c1, c("Test statistic", "Degrees of freedom", PLABEL))
        c2 <- c(c2, c(
          sprintf(num.format, TEST[[block]]$stat),
          ifelse(TEST[[block]]$df %% 1 == 0, # integer
            TEST[[block]]$df,
            sprintf(num.format, TEST[[block]]$df)
          ),
          sprintf(num.format, TEST[[block]]$pvalue)
        ))
        c3 <- c(c3, c("", "", ""))
      }

      # two-column
    } else {
      # print label
      c1 <- c2 <- c3 <- character(0L)
      if (!is.null(TEST[[scaled.idx]]$label)) {
        c1 <- c(c1, TEST[[scaled.idx]]$label)
        c2 <- c(c2, "")
        c3 <- c(c3, "")
      }
      if (is.na(TEST[[block]]$df) || TEST[[block]]$df == 0L) {
        c1 <- c(c1, c("Test Statistic", "Degrees of freedom"))
        c2 <- c(
          c2,
          c(
            sprintf(num.format, TEST[[scaled.idx]]$stat),
            ifelse(TEST[[scaled.idx]]$df %% 1 == 0, # integer
              TEST[[scaled.idx]]$df,
              sprintf(num.format, TEST[[scaled.idx]]$df)
            )
          )
        )
        c3 <- c(
          c3,
          c(
            sprintf(num.format, TEST[[block]]$stat),
            ifelse(TEST[[block]]$df %% 1 == 0, # integer
              TEST[[block]]$df,
              sprintf(num.format, TEST[[block]]$df)
            )
          )
        )
      } else {
        if (!is.null(TEST[[scaled.idx]]$refdistr)) {
          if (TEST[[scaled.idx]]$refdistr == "chisq") {
            PLABEL <- "P-value (Chi-square)"
          } else if (TEST[[scaled.idx]]$refdistr == "unknown") {
            PLABEL <- "P-value (Unknown)"
          } else {
            PLABEL <- "P-value"
          }
        }
        c1 <- c(c1, c(
          "Test Statistic", "Degrees of freedom", PLABEL,
          "Scaling correction factor"
        ))
        c2 <- c(
          c2,
          c(
            sprintf(num.format, TEST[[scaled.idx]]$stat),
            ifelse(TEST[[scaled.idx]]$df %% 1 == 0, # integer
              TEST[[scaled.idx]]$df,
              sprintf(num.format, TEST[[scaled.idx]]$df)
            ),
            sprintf(num.format, TEST[[scaled.idx]]$pvalue), ""
          )
        )
        c3 <- c(
          c3,
          c(
            sprintf(num.format, TEST[[block]]$stat),
            ifelse(TEST[[block]]$df %% 1 == 0, # integer
              TEST[[block]]$df,
              sprintf(num.format, TEST[[block]]$df)
            ),
            sprintf(num.format, TEST[[block]]$pvalue),
            sprintf(num.format, TEST[[block]]$scaling.factor)
          )
        )

        if (TEST[[block]]$test == "scaled.shifted") {
          if (ngroups == 1L ||
            length(TEST[[block]]$shift.parameter) == 1L) {
            c1 <- c(c1, "Shift parameter")
            c2 <- c(c2, "")
            c3 <- c(
              c3,
              sprintf(num.format, TEST[[block]]$shift.parameter)
            )
          } else {
            c1 <- c(c1, "Shift parameter for each group:")
            c2 <- c(c2, "")
            c3 <- c(c3, "")
            for (g in 1:ngroups) {
              c1 <- c(c1, sprintf("    %-38s", group.label[[g]]))
              c2 <- c(c2, "")
              c3 <- c(c3, sprintf(
                num.format,
                TEST[[block]]$shift.parameter[g]
              ))
            }
          }
        } # shift

        # which correction factor?
        c1 <- c(c1, paste("  ", TEST[[block]]$label, sep = ""))
        c2 <- c(c2, "")
        c3 <- c(c3, "")
      }
    }

    # if twocolumn, label first row
    if (twocolumn && block == BLOCKS[1]) {
      c1 <- c("", c1)
      c2 <- c("Standard", c2)
      c3 <- c("Scaled", c3)
    } else {
      # empty row
      c1 <- c("", c1)
      c2 <- c("", c2)
      c3 <- c("", c3)
    }

    # if information type is different from 'se', print it
    if (length(information) > 1L &&
      information[1] != information[2]) {
      c1 <- c(c1, "Information")
      tmp.txt <- information[2]
      c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
        substring(tmp.txt, 2),
        sep = ""
      ))
      c3 <- c(c3, "")
    }
    # if h1.information type is different from 'se', print it
    if (length(h1.information) > 1L &&
      h1.information[1] != h1.information[2]) {
      c1 <- c(c1, "Information saturated (h1) model")
      tmp.txt <- h1.information[2]
      c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
        substring(tmp.txt, 2),
        sep = ""
      ))
      c3 <- c(c3, "")
    }
    # if observed.information type is different from 'se', print it
    if (length(observed.information) > 1L &&
      information[2] == "observed" &&
      (observed.information[1] !=
        observed.information[2])) {
      c1 <- c(c1, "Observed information based on")
      tmp.txt <- observed.information[2]
      c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
        substring(tmp.txt, 2),
        sep = ""
      ))
      c3 <- c(c3, "")
    }


    # format c1/c2/c3 (note: fitMeasures uses 35/16/8)
    c1 <- format(c1, width = 43L)
    c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right")
    c3 <- format(c3, width = 8L + nd, justify = "right")

    # create character matrix
    if (twocolumn) {
      M <- cbind(c1, c2, c3, deparse.level = 0)
    } else {
      M <- cbind(c1, c2, deparse.level = 0)
    }
    colnames(M) <- rep("", ncol(M))
    rownames(M) <- rep(" ", nrow(M))

    # print
    write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)

    # multiple groups?
    ngroups <- ngroups
    if (ngroups > 1L && !is.null(TEST[[block]]$stat.group)) {
      c1 <- c2 <- c3 <- character(ngroups)
      for (g in 1:ngroups) {
        tmp <- sprintf("  %-40s", group.label[[g]])
        c1[g] <- format(tmp, width = 43L)
        if (!twocolumn) {
          tmp <- sprintf(num.format, TEST[[block]]$stat.group[g])
          c2[g] <- format(tmp,
            width = 8L + max(0, (nd - 3L)) * 4L,
            justify = "right"
          )
        } else {
          tmp <- sprintf(num.format, TEST[[block]]$stat.group[g])
          c2[g] <- format(tmp,
            width = 8L + max(0, (nd - 3L)) * 4L,
            justify = "right"
          )
          tmp <- sprintf(num.format, TEST[[block]]$stat.group[g])
          c3[g] <- format(tmp, width = 8L + nd, justify = "right")
        }
      }
      if (twocolumn) {
        M <- cbind(c1, c2, c3, deparse.level = 0)
      } else {
        M <- cbind(c1, c2, deparse.level = 0)
      }
      colnames(M) <- rep("", ncol(M))
      rownames(M) <- rep(" ", nrow(M))
      cat("  Test statistic for each group:\n")
      write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
    }
  } # blocks

  # invisible(M)
}

lav_lavaan_step04_partable <- function(slotParTable = NULL, # nolint
                                       model = NULL,
                                       flat.model = NULL,
                                       lavoptions = NULL,
                                       lavdata = NULL,
                                       constraints = NULL) {
  # # # # # # # # # # # #
  # #  4. lavpartable # #
  # # # # # # # # # # # #

  # if slotParTable not null
  #   copy slotParTable to lavpartable
  # else
  #   if model is character or formula
  #     create a temporary variable tmp.data.ov equal to lavdata@ov
  #     if estimator "catML"
  #       set meanstructure to FALSE
  #       set the member type in the temporary variable tmp.data.ov to a
  #         numeric vector with all zeroes
  #     create lavpartable via function lavParTable (=lav_model_partable)
  #                     using the temporary variable for parameter varTable
  #   else
  #     if model is lavaan object
  #       set lavpartable = parTable(model)
  #     else
  #       if model is a list
  #         set lavpartable to
  #           as.list(lav_partable_complete(as.list(flat.model)))
  #       else
  #         *** error ***
  # if slotParTable is NULL check lavpartable via lav_partable_check
  # if lavoptions$optim.method is "em" and there are variances specified in
  #   partable with free = 0L and
  #    starting value ustart 0, set ustart for these variances to
  #    lavoptions$em.zerovar.offset

  if (!is.null(slotParTable)) {
    lavpartable <- lav_partable_set_cache(slotParTable)
  } else if (is.character(model) ||
    inherits(model, "formula") ||
	# model was already a flat.model
	(is.list(model) && !is.null(model$mod.idx) &&
	 !is.null(attr(model, "modifiers")))) {
    if (lav_verbose()) {
      cat("lavpartable        ...")
    }
    # check flat.model before we proceed
    if (lav_debug()) {
      print(as.data.frame(flat.model))
    }
    # catch ~~ of fixed.x covariates if fixed.x = TRUE
    # --> done inside lav_model_partable!

    # if(lavoptions$fixed.x) {
    #    tmp <- lav_partable_vnames(flat.model, type = "ov.x",
    #                               ov.x.fatal = FALSE, warn = TRUE)
    # tmp <- try(lav_partable_vnames(flat.model, type = "ov.x",
    #                                         ov.x.fatal = TRUE),
    #           silent = TRUE)
    # if(inherits(tmp, "try-error")) {
    #    warning("lavaan WARNING: syntax contains parameters involving ",
    #      "exogenous covariates; switching to fixed.x = FALSE")
    #    lavoptions$fixed.x <- FALSE
    # }
    # }
    # if(lavoptions$conditional.x) {
    #    tmp <- lav_partable_vnames(flat.model, type = "ov.x", ov.x.fatal = TRUE)
    # }
    tmp.data.ov <- lavdata@ov
    if (lavoptions$estimator == "catML") {
      lavoptions$meanstructure <- FALSE
      tmp.data.ov$type <- rep("numeric", length(tmp.data.ov$type))
    }
    lavpartable <-
      lavParTable(
        model = flat.model,
        constraints = constraints,
        varTable = tmp.data.ov,
        ngroups = lavdata@ngroups,
        meanstructure = lavoptions$meanstructure,
        int.ov.free = lavoptions$int.ov.free,
        int.lv.free = lavoptions$int.lv.free,
        marker.int.zero = lavoptions$marker.int.zero,
        orthogonal = lavoptions$orthogonal,
        orthogonal.x = lavoptions$orthogonal.x,
        orthogonal.y = lavoptions$orthogonal.y,
        orthogonal.efa = lavoptions$rotation.args$orthogonal,
        conditional.x = lavoptions$conditional.x,
        fixed.x = lavoptions$fixed.x,
        std.lv = lavoptions$std.lv,
        correlation = lavoptions$correlation,
        composites = lavoptions$composites,
        effect.coding = lavoptions$effect.coding,
        ceq.simple = lavoptions$ceq.simple,
        parameterization = lavoptions$parameterization,
        auto.fix.first = lavoptions$auto.fix.first,
        auto.fix.single = lavoptions$auto.fix.single,
        auto.var = lavoptions$auto.var,
        auto.cov.lv.x = lavoptions$auto.cov.lv.x,
        auto.cov.y = lavoptions$auto.cov.y,
        auto.th = lavoptions$auto.th,
        auto.delta = lavoptions$auto.delta,
        auto.efa = lavoptions$auto.efa,
        group.equal = lavoptions$group.equal,
        group.partial = lavoptions$group.partial,
        group.w.free = lavoptions$group.w.free,
        as.data.frame. = FALSE
      )
    lavpartable <- lav_partable_set_cache(lavpartable)
    if (lav_verbose()) {
      cat(" done.\n")
    }
  } else if (inherits(model, "lavaan")) {
    lavpartable <- lav_partable_set_cache(as.list(parTable(model)), model@pta)
  } else if (is.list(model)) {
    # we already checked this when creating flat.model
    # but we may need to complete it
    lavpartable <- as.list(flat.model) # in case model is a data.frame
    # complete table
    lavpartable <- as.list(lav_partable_complete(lavpartable))
    lavpartable <- lav_partable_set_cache(lavpartable)
  } else {
    lav_msg_stop(gettextf(
      "model [type = %s] is not of type character or list", class(model)))
    }
  if (lav_debug()) {
    print(as.data.frame(lavpartable))
  }

  # at this point, we should check if the partable is complete
  # or not; this is especially relevant if the lavaan() function
  # was used, but the user has forgotten some variances/intercepts...
  if (is.null(slotParTable)) {
    junk <- lav_partable_check(lavpartable,
      categorical = lavoptions$.categorical
    )
    rm(junk)
  }

  # for EM only (for now), force fixed-to-zero (residual) variances
  # to be slightly larger than zero
  if (lavoptions$optim.method == "em") {
    zero.var.idx <- which(lavpartable$op == "~~" &
      lavpartable$lhs == lavpartable$rhs &
      lavpartable$free == 0L &
      lavpartable$ustart == 0)
    if (length(zero.var.idx) > 0L) {
      lavpartable$ustart[zero.var.idx] <- lavoptions$em.zerovar.offset
    }
    lavpartable <- lav_partable_set_cache(lavpartable, NULL, force = TRUE)
  }

  list(
    lavoptions  = lavoptions,
    lavpartable = lavpartable
  )
}

# initial version YR 02/08/2010

# YR 28 Jan 2017: add lavOptions(), lav_options_default()
# LDW 16 Apr 2024: move lavOptions and lav_options_default to separate file

# help functions for lav_options_set ####
# help function to determine estimator 'group'
lav_options_estimatorgroup <- function(estimator) {
  goal <- switch(estimator,
    ml = ,
    mlf = ,
    mlm = ,
    mlmv = ,
    mlmvs = ,
    mlr = "ML",
    catml = "catML",
    dwls = ,
    wlsm = ,
    wlsmv = ,
    wlsmvs = "DWLS",
    uls = ,
    ulsm = ,
    ulsmv = ,
    ulsmvs = "ULS",
    none = "none",
    toupper(estimator)
  )
  goal
}
lav_options_checkinterval <- function(x, nm, num2int) {
  if (num2int) x <- as.integer(x)
  oks <- vapply(x, function(x1) {
    (x1 > nm$bounds[1] || (x1 == nm$bounds[1] && nm$first.in)) &&
      (x1 < nm$bounds[2] || (x1 == nm$bounds[2] && nm$last.in))
  }, TRUE)
  all(oks)
}
lav_options_checkvalues <- function(optname, optvalue, chr) {
  optvalid <- names(chr)
  if (is.null(optvalid)) optvalid <- chr
  if (any(optvalid == "empty.string")) {
    optvalid[optvalid == "empty.string"] <- ""
  }
  optvals <- gsub("[_-]", ".", tolower(optvalue))
  optvalsok <- match(optvals, optvalid)
  if (any(is.na(optvalsok))) {
    lav_msg_stop(sprintf(
      ngettext(
        length(optvalue[is.na(optvalsok)]),
        "invalid value in %1$s option: %2$s.",
        "invalid values in %1$s option: %2$s."
      ),
      optname,
      lav_msg_view(optvalue[is.na(optvalsok)], log.sep = "none")
    ))
  }
  as.vector(chr[optvalsok])
}
lav_options_check <- function(opts, opt.check, subname) { # nolint
  opt.names <- names(opts)
  hiddens <- startsWith(opt.names, ".")
  if (any(hiddens)) { # remove hidden options temporarily
    opts.hidden <- opts[hiddens]
    opts <- opts[!hiddens]
    opt.names <- opt.names[!hiddens]
  }
  check.names <- names(opt.check)
  match.opt <- match(opt.names, check.names)
  if (any(is.na(match.opt))) {
    lav_msg_stop(gettextf(
      "Some option(s) unknown: %s !",
      lav_msg_view(opt.names[is.na(match.opt)], log.sep = "none")
    ))
  }
  for (j in seq_along(opts)) {
    opt.name <- opt.names[j]
    opt.value <- opts[[j]]
    opt.check1 <- opt.check[[match.opt[j]]]
    if (!is.null(attr(opt.check1, "SUB"))) {
      opts[[j]] <- lav_options_check(
        opt.value, opt.check1,
        paste0(opt.name, "$")
      )
      next
    }
    # check length of option value
    if (length(opt.value) < opt.check1$oklen[1]) {
      lav_msg_stop(gettextf(
        "Length of option '%1$s' value must be at least %2$s.",
        paste0(subname, opt.name), opt.check1$oklen[1]
      ))
    }
    if (length(opt.value) > abs(opt.check1$oklen[2])) {
      if (opt.check1$oklen[2] > 0L) {
        lav_msg_stop(gettextf(
          "Length of option '%1$s' value must be maximum %2$s.",
          paste0(subname, opt.name), opt.check1$oklen[2]
        ))
      } else {
        lav_msg_warn(gettextf(
          "Length of option '%1$s' value should be maximum %2$s.
          Only first %3$s elements used.",
          paste0(subname, opt.name), -opt.check1$oklen[2],
          -opt.check1$oklen[2]
        ))
      }
    }
    if (is.null(opt.check1$bl)) opt.check1$bl <- FALSE
    if (!is.null(opt.check1$chr) || !is.null(opt.check1$nm) ||
      opt.check1$bl) {
      if (!opt.check1$bl || !is.logical(opt.value)) {
        if (!is.null(opt.check1$nm) && is.numeric(opt.value)) {
          num2int <- FALSE
          if (!is.null(opt.check1$num2int)) num2int <- opt.check1$num2int
          if (!lav_options_checkinterval(opt.value, opt.check1$nm, num2int)) {
            lav_msg_stop(gettextf(
              "Value(s) of option %1$s out of range (%2$s)!",
              paste0(subname, opt.name),
              paste0(
                opt.check1$nm$bounds[1],
                if (opt.check1$nm$first.in) " <= " else " < ",
                "x",
                if (opt.check1$nm$last.in) " <= " else " < ",
                opt.check1$nm$bounds[2]
              )
            ))
          }
        }
        if (!is.null(opt.check1$chr) && is.character(opt.value)) {
          opt.value <- lav_options_checkvalues(
            opt.name, opt.value,
            opt.check1$chr
          )
          opts[[j]] <- opt.value
        }
      }
    }
  }
  if (any(hiddens)) { # add hidden options
    opts <- modifyList(opts, opts.hidden)
  }
  opts
}
# this function collects and checks the user-provided options/arguments,
# and fills in the "default" values, or changes them in an attempt to
# produce a consistent set of values...
#
# returns a list with the named options
lav_options_set <- function(opt = NULL) {
  # check the presence of necessary hidden options ####
  if (is.null(opt$.categorical) || is.null(opt$.multilevel) ||
    is.null(opt$.clustered)) {
    lav_msg_fixme(
      ".categorical, .multilevel and .clustered must be present"
    )
  }

  # get opt.default and opt.check ####
  if (!exists("opt.check", lavaan_cache_env)) lav_options_default()
  opt.check <- get("opt.check", lavaan_cache_env)

  if (lav_debug()) {
    cat("lavaan DEBUG: lavaanOptions IN\n")
    str(opt)
    opt$optim.partrace <- TRUE
  }

  # options OPT for which there also exist OPT.args and opt$OPT is a list
  # -> split in opt$OPT and opt$OPT.args
  welke <- which(paste0(names(opt.check), ".args") %in% names(opt.check))
  for (j in welke) {
    optname <- names(opt.check)[j]
    optname.args <- paste0(optname, ".args")
    if (is.list(opt[[optname]])) {
      if (optname == "bootstrap" && !is.null(opt[[optname]][["R"]])) {
        # special case for bootstrap, instead of "bootstrap" replications
        # argument can be "R"
        opt[[optname]][[optname]] <- opt[[optname]][["R"]]
        opt[[optname]][["R"]] <- NULL
      }
      opt[[optname.args]] <- opt[[optname]]
      opt[[optname.args]][[optname]] <- NULL
      opt[[optname]] <- opt[[optname]][[optname]]
    }
  }

  # check options with definitions ####
  opt <- lav_options_check(opt, opt.check, "")

  # check option 'start'
  if (is.character(opt$start) && all(opt$start != c("default", "simple"))) {
    lav_msg_stop(gettext(
      "start option must be 'default', 'simple', a fitted object,
      a vector of parameter values, or a parameter table"
    ))
  }

  # first of all: set estimator ####
  if (opt$estimator == "default") {
    if (opt$.categorical) {
      opt$estimator <- "wlsmv"
    } else {
      opt$estimator <- "ml"
    }
  }

  # defaults for opt$sample.cov.rescale
  if (opt$sample.cov.rescale == "default") {
    opt$sample.cov.rescale <- switch(opt$estimator,
      dls = TRUE,
      fabin2 = ,
      fabin3 = ,
      mgm = ,
      js = ,
      jsa = ,
      bentler1982 = TRUE,
      iv = TRUE,
      "default"
    )
  }

  # option defaults specific for mimic=...
  opt <- lav_options_mimic(opt)

  # store opt$estimator as estimator.orig in upper case
  opt$estimator.orig <- toupper(opt$estimator)

  # rename names of test statistics if needed, check for invalid values ####
  opt$test <- lav_test_rename(opt$test, check = TRUE)

  # same for standard.test
  opt$standard.test <- lav_test_rename(opt$standard.test, check = TRUE)

  # same for scaled.test
  opt$scaled.test <- lav_test_rename(opt$scaled.test, check = TRUE)

  # rename names of se values, check illegal combinations se/estimator ####
  # pass-through function: may change value of information
  # for backwards compatibility (eg if se = "expected")
  opt <- lav_options_check_se(opt)

  # do.fit FALSE implies se="none" and test="none" (unless not default) ####
  if (!opt$do.fit) {
    if (opt$se == "default") opt$se <- "none"
    if (opt$test[1] == "default") opt$test <- "none"
  }

  # marker.int.fixed ####
  if (opt$marker.int.zero) {
    opt$meanstructure <- TRUE
    opt$int.ov.free <- TRUE
    if ((is.logical(opt$effect.coding) && opt$effect.coding) ||
      (is.character(opt$effect.coding) && nchar(opt$effect.coding) > 0L)) {
      lav_msg_stop(gettext(
        "effect coding cannot be combined with marker.int.zero = TRUE option"
      ))
    }
    if (opt$std.lv) {
      lav_msg_stop(gettext(
        "std.lv = TRUE cannot be combined with marker.int.zero = TRUE"
      ))
    }
  }

  # group.equal and group.partial ####
  if (length(opt$group.equal) > 0L && opt$group.equal[1] == "none") {
    opt$group.equal <- character(0)
  } else if (is.null(opt$group.equal) || all(nchar(opt$group.equal) == 0L)) {
    opt$group.equal <- character(0)
  }

  if (is.null(opt$group.partial) || all(nchar(opt$group.partial) == 0L)) {
    opt$group.partial <- character(0)
  } else if (length(opt$group.partial) == 0) {
    # nothing to do
  } else {
    # strip white space
    opt$group.partial <- gsub("[[:space:]]+", "", opt$group.partial)
  }

  # if categorical, and group.equal contains "intercepts", also add
  # thresholds (and vice versa)
  # not any longer since 0.6-20
  # if (opt$.categorical && any("intercepts" == opt$group.equal)) {
  #  opt$group.equal <- unique(c(opt$group.equal, "thresholds"))
  # }
  # if (opt$.categorical && any("thresholds" == opt$group.equal)) {
  #  opt$group.equal <- unique(c(opt$group.equal, "intercepts"))
  # }

  # clustered ####
  # brute-force override (for now)
  if (opt$.clustered && !opt$.multilevel) {
    opt$meanstructure <- TRUE

    if (opt$estimator == "mlr") {
      opt$estimator <- "ml"
      opt$test <- "yuan.bentler.mplus"
      opt$se <- "robust.cluster"
    } else if (opt$estimator == "mlm") {
      opt$estimator <- "ml"
      opt$test <- "satorra.bentler"
      opt$se <- "robust.cluster.sem"
    } else if (opt$.categorical && opt$estimator != "pml") {
      opt$test <- "satorra.bentler"
      opt$se <- "robust.cluster.sem"
    }

    # test ####
    if (length(opt$test) == 1L && opt$test == "default") {
      opt$test <- "yuan.bentler.mplus"
    } else if (all(opt$test %in% c(
      "none", "standard",
      "satorra.bentler",
      "yuan.bentler", "yuan.bentler.mplus"
    ))) {
      # nothing to do
    } else if (opt$se == "robust") {
      opt$test <- "yuan.bentler.mplus"
    } else {
      lav_msg_stop(
        gettextf(
          "`test' argument must one of %s in the clustered case",
          lav_msg_view(c(
            "none", "yuan.bentler", "yuan.bentler.mplus",
            "satorra.bentler"
          ), log.sep = "or")
        )
      )
    }

    # se ####
    if (opt$se == "default") {
      opt$se <- "robust.cluster"
    } else if (any(opt$se == c(
      "none", "robust.cluster",
      "robust.cluster.sem"
    ))) {
      # nothing to do
    } else if (opt$se == "robust") {
      opt$se <- "robust.cluster"
    }

    # information ####
    if (opt$information[1] == "default") {
      if (opt$se == "robust.cluster" && opt$estimator == "ml") {
        opt$information[1] <- "observed"
      } else {
        opt$information[1] <- "expected"
      }
    }
    if (length(opt$information) > 1L && opt$information[2] == "default") {
      if (opt$se == "robust.cluster") {
        opt$information[2] <- "observed"
      } else {
        opt$information[2] <- "expected"
      }
    }
  }

  # multilevel ####
  # brute-force override (for now)
  if (opt$.multilevel) {
    opt$meanstructure <- TRUE

    # test
    if (length(opt$test) == 1L && opt$test == "default") {
      # ok, will be set later
    } else if (all(opt$test %in% c(
      "none", "standard", "yuan.bentler",
      "yuan.bentler.mplus"
    ))) {
      # nothing to do
    } else {
      lav_msg_stop(gettextf(
        "`test' argument must one of %s in the multilevel case",
        lav_msg_view(c(
          "none", "standard", "yuan.bentler",
          "yuan.bentler.mplus"
        ), log.sep = "or")
      ))
    }

    # se
    if (opt$se == "default") {
      # ok, will be set later
    } else if (any(opt$se == c(
      "none", "standard", "robust.huber.white", "sandwich"
    ))) {
      # nothing to do
    } else if (opt$se == "robust") {
      opt$se <- "robust.huber.white"
    } else {
      lav_msg_stop(gettextf(
        "`se' argument must one of %s  in the multilevel case",
        lav_msg_view(c("none", "standard", "robust.huber.white"),
          log.sep = "or"
        )
      ))
    }

    # information
    if (opt$information[1] == "default") {
      opt$information[1] <- "observed"
    }
    if (length(opt$information) > 1L && opt$information[2] == "default") {
      opt$information[2] <- "observed"
    }
  }

  # missing ####
  if (opt$missing == "default") {
    opt$missing <- "listwise"
  } else if (opt$missing == "ml") {
    if (opt$.categorical) {
      lav_msg_stop(gettextf(
        "missing = %s not available in the categorical setting",
        dQuote(opt$missing)
      ))
    }
    if (any(opt$estimator == c(
      "mlm", "mlmv", "gls", "wls", "wlsm", "wlsmv",
      "uls", "ulsm", "ulsmv", "pml", "dls"
    ))) {
      lav_msg_stop(gettextf(
        "missing=%1$s is not allowed for estimator %2$s",
        dQuote(opt$missing),
        dQuote(lav_options_estimatorgroup(opt$estimator.orig))
      ))
    }
  } else if (opt$missing == "ml.x") {
    if (opt$.categorical) {
      lav_msg_stop(gettextf(
        "missing = %s not available in the categorical setting",
        dQuote(opt$missing)
      ))
    }
    if (any(opt$estimator == c(
      "mlm", "mlmv", "gls", "wls", "wlsm", "wlsmv",
      "uls", "ulsm", "ulsmv", "pml", "dls"
    ))) {
      lav_msg_stop(gettextf(
        "missing=%1$s is not allowed for estimator %2$s",
        dQuote(opt$missing),
        dQuote(lav_options_estimatorgroup(opt$estimator.orig))
      ))
    }
  } else if (opt$missing == "two.stage") {
    if (opt$.categorical) {
      lav_msg_stop(gettextf(
        "missing = %s not available in the categorical setting",
        dQuote(opt$missing)
      ))
    }
    if (any(opt$estimator == c(
      "mlm", "mlmv", "gls", "wls", "wlsm", "wlsmv",
      "uls", "ulsm", "ulsmv", "pml", "mml", "dls"
    ))) {
      lav_msg_stop(gettextf(
        "missing=%1$s is not allowed for estimator %2$s",
        dQuote(opt$missing),
        dQuote(lav_options_estimatorgroup(opt$estimator.orig))
      ))
    }
  } else if (opt$missing == "robust.two.stage") {
    if (opt$.categorical) {
      lav_msg_stop(gettextf(
        "missing = %s not available in the categorical setting",
        dQuote(opt$missing)
      ))
    }
    if (any(opt$estimator == c(
      "mlm", "mlmv", "gls", "wls", "wlsm", "wlsmv",
      "uls", "ulsm", "ulsmv", "pml", "mml", "dls"
    ))) {
      lav_msg_stop(gettextf(
        "missing=%1$s is not allowed for estimator %2$s",
        dQuote(opt$missing),
        dQuote(lav_options_estimatorgroup(opt$estimator.orig))
      ))
    }
  } else if (opt$missing == "doubly.robust") {
    if (opt$estimator != "pml") {
      lav_msg_stop(gettextf(
        "missing=%s option only available for estimator PML",
        dQuote(opt$missing)
      ))
    }
  }

  # check missing ####
  if (any(opt$missing == c("ml", "ml.x")) &&
    opt$se %in% c("robust.sem", "robust.sem.nt")) {
    lav_msg_warn(gettextf(
      "missing will be set to %1$s for se = %2$s.",
      dQuote("listwise"), dQuote(opt$se)
    ))
    opt$missing <- "listwise"
  }
  if (any(opt$missing == c("ml", "ml.x")) &&
    any(opt$test %in% c(
      "satorra.bentler",
      "mean.var.adjusted", "scaled.shifted"
    ))) {
    lav_msg_warn(gettextf(
      "missing will be set to %s for satorra.bentler style test",
      dQuote("listwise")
    ))
    opt$missing <- "listwise"
  }

  # checks if missing = "two.stage" or "robust.two.stage" ####
  if (any(opt$missing == c("two.stage", "robust.two.stage"))) {
    opt$meanstructure <- TRUE
    # se
    if (opt$se == "default") {
      if (opt$missing == "two.stage") {
        opt$se <- "two.stage"
      } else {
        opt$se <- "robust.two.stage"
      }
    } else if (opt$missing == "two.stage" &&
      opt$se == "two.stage") {
      # nothing to do
    } else if (opt$missing == "robust.two.stage" &&
      opt$se == "robust.two.stage") {
      # nothing to do
    } else {
      lav_msg_warn(gettextf(
        "se will be set to %1$s if missing = %2$s",
        dQuote(opt$missing), dQuote(opt$missing)
      ))
      opt$se <- opt$missing
    }
    # information
    if (opt$information[1] == "default") {
      # for both two.stage and robust.two.stage
      opt$information[1] <- "observed"
    } else if (opt$information[1] == "first.order") {
      lav_msg_warn(gettextf(
        "information will be set to %1$s if missing = %2$s",
        dQuote("observed"), dQuote(opt$missing)
      ))
      opt$information[1] <- "observed"
    }

    # observed.information (ALWAYS "h1" for now)
    opt$observed.information[1] <- "h1"
    opt$observed.information[2] <- "h1"

    # new in 0.6-9: ALWAYS h1.information = "unstructured"
    opt$h1.information <- c("unstructured", "unstructured")

    if (length(opt$information) > 1L && opt$information[2] == "default") {
      # for both two.stage and robust.two.stage
      opt$information[2] <- "observed"
    }

    # test
    if (length(opt$test) > 1L) {
      lav_msg_warn(gettextf(
        "test= argument can only contain a single element if missing = %s
        (taking the first)", dQuote(opt$missing)
      ))
      opt$test <- opt$test[1]
    }

    if (length(opt$test) == 1L && opt$test == "default") {
      opt$test <- "satorra.bentler"
    } else if (length(opt$test) == 1L && any(
      opt$test == c("satorra", "sb", "satorra.bentler", "satorra-bentler")
    )) {
      opt$test <- "satorra.bentler"
    } else {
      lav_msg_warn(gettextf(
        "test will be set to %1$s if missing = %2$s",
        dQuote("satorra.bentler"), dQuote(opt$missing)
      ))
      opt$test <- "satorra.bentler"
    }
  }

  # meanstructure ####
  if (is.logical(opt$meanstructure)) {
    if (opt$meanstructure == FALSE) {
      if (any(opt$missing == c("ml", "ml.x", "two.stage"))) {
        lav_msg_warn(gettextf(
          "missing argument %s forces meanstructure = TRUE",
          opt$missing
        ))
      }
    }
  } else if (opt$meanstructure == "default") {
    # by default: no meanstructure!
    if (opt$estimator == "pml") {
      opt$meanstructure <- TRUE
    } else {
      opt$meanstructure <- FALSE
    }
  }

  # bootstrap ####
  if (is.numeric(opt$bootstrap)) {
    opt$bootstrap <- list(R = as.integer(opt$bootstrap))
  }
  if (opt$se == "bootstrap") {
    opt$information[1] <- "observed"
    if (length(opt$information) > 1L && opt$information[2] == "default") {
      opt$information[2] <- "observed"
    }
  }

  # specific per estimator (group) ####
  opt <- switch(opt$estimator,
    ml = ,
    mlf = ,
    mlm = ,
    mlmv = ,
    mlmvs = ,
    mlr = lav_options_est_ml(opt),
    gls = lav_options_est_gls(opt),
    ntrls = lav_options_est_ntrls(opt),
    catml = lav_options_est_catml(opt),
    wls = lav_options_est_wls(opt),
    dls = lav_options_est_dls(opt),
    dwls = ,
    wlsm = ,
    wlsmv = ,
    wlsmvs = lav_options_est_dwls(opt),
    uls = ,
    ulsm = ,
    ulsmv = ,
    ulsmvs = lav_options_est_uls(opt),
    pml = lav_options_est_pml(opt),
    fml = lav_options_est_fml(opt),
    reml = lav_options_est_reml(opt),
    mml = lav_options_est_mml(opt),
    fabin2 = ,
    fabin3 = ,
    mgm = ,
    js = ,
    jsa = ,
    bentler1982 = lav_options_est_fabin(opt),
    iv = lav_options_est_iv(opt),
    lav_options_est_none(opt) # estimator = none
  )

  # after code specific to estimator types                          ####
  # optim.method - if still "default" at this point -> set to "nlminb"
  if (opt$optim.method == "default") {
    opt$optim.method <- "nlminb"
  }

  # special stuff for categorical
  if (opt$.categorical) {
    opt$meanstructure <- TRUE # Mplus style
    if (lav_options_estimatorgroup(opt$estimator) == "ML") {
      lav_msg_stop(gettext(
        "estimator ML for ordered data is not supported yet. Use WLSMV instead."
      ))
    }
  }

  # link
  if (opt$link == "logit") {
    if (opt$estimator != "mml") {
      lav_msg_warn(gettextf(
        "link will be set to %1$s for estimator = %2$s",
        dQuote("probit"), dQuote(opt$estimator)
      ))
    }
  }

  # likelihood approach (wishart or normal) + sample.cov.rescale
  if (!any(lav_options_estimatorgroup(opt$estimator) ==
    c("ML", "REML", "PML", "FML", "NTRLS", "catML"))) {
    # if(opt$likelihood != "default") {
    #    lav_msg_stop(gettext(
    #    "likelihood argument is only relevant if estimator = ML"))
    # }
    if (opt$sample.cov.rescale == "default") {
      opt$sample.cov.rescale <- FALSE
    } # else {
    #    lav_msg_warn(gettext(
    #    "sample.cov.rescale argument is only relevant if estimator = ML"))
    # }
  } else { # ml and friends
    if (any(lav_options_estimatorgroup(opt$estimator) == c("PML", "FML"))) {
      opt$likelihood <- "normal"
    } else if (opt$likelihood == "default") {
      opt$likelihood <- "normal"
    }

    if (opt$sample.cov.rescale == "default") {
      opt$sample.cov.rescale <- FALSE
      if (opt$likelihood == "normal") {
        opt$sample.cov.rescale <- TRUE
      }
    }
  }

  # se information
  if (opt$information[1] == "default") {
    if (any(opt$missing == c("ml", "ml.x")) ||
      any(opt$se == c("robust.huber.white", "first.order"))) {
      # nchar(opt$constraints) > 0L) {
      opt$information[1] <- "observed"
    } else {
      opt$information[1] <- "expected"
    }
  }

  # first.order information can not be used with robust
  if (opt$information[1] == "first.order" &&
    any(opt$se == c("robust.huber.white", "robust.sem", "robust.sem.nt"))) {
    lav_msg_stop(gettextf(
      "information must be either %s if robust standard errors are requested.",
      lav_msg_view(c("expected", "observed"), log.sep = "or")
    ))
  }

  # test information
  if (length(opt$information) == 1L) {
    opt$information <- rep(opt$information, 2L)
  }
  if (opt$information[2] == "default") {
    if (any(opt$missing == c("ml", "ml.x")) ||
      any(opt$se == c("robust.huber.white", "first.order"))) {
      # nchar(opt$constraints) > 0L) {
      opt$information[2] <- "observed"
    } else {
      opt$information[2] <- "expected"
    }
  }

  # first.order information cannot be used with robust
  if (opt$information[2] == "first.order" &&
    any(opt$test %in% c(
      "satorra.bentler", "yuan.bentler",
      "yuan.bentler.mplus",
      "mean.var.adjusted", "scaled.shifted"
    ))) {
    lav_msg_stop(gettextf(
      "information must be either %s if robust test statistics are requested.",
      lav_msg_view(c("expected", "observed"), log.sep = "or")
    ))
  }


  if (length(opt$observed.information) == 1L) {
    opt$observed.information <- rep(opt$observed.information, 2L)
  }

  if (all(opt$observed.information[2] != c("hessian", "h1"))) {
    if (opt$observed.information[2] == "default") {
      if (any(opt$test %in% c(
        "satorra.bentler",
        "yuan.bentler",
        "yuan.bentler.mplus",
        "mean.var.adjusted",
        "scaled.shifted"
      ))) {
        if (length(opt$test) > 1L) {
          opt$observed.information[2] <- "h1" # CHANGED in 0.6-6!
          if (any(opt$test == "yuan.bentler.mplus")) {
            lav_msg_warn(gettext(
              "observed.information for ALL test statistics is set to h1."
            ))
          }
        } else {
          if (opt$estimator == "PML" ||
            opt$test[1] == "yuan.bentler.mplus") {
            opt$observed.information[2] <- "hessian"
          } else {
            opt$observed.information[2] <- "h1" # CHANGED in 0.6-6!
          }
        }
      } else {
        # default is "hessian"
        opt$observed.information[2] <- "hessian"
      }
    }
  }

  if (length(opt$h1.information) == 1L) {
    opt$h1.information <- rep(opt$h1.information, 2L)
  }

  if (opt$h1.information.meat == "default") {
    opt$h1.information.meat <- opt$h1.information[1]
  }

  # check information if estimator is uls/wls and friends
  if (any(lav_options_estimatorgroup(opt$estimator) ==
    c("ULS", "WLS", "DWLS"))) {
    if (opt$information[1] != "expected") {
      lav_msg_warn(gettextf(
        "information will be set to %1$s for estimator = %2$s",
        dQuote("expected"), dQuote(opt$estimator)
      ))
      opt$information <- rep.int("expected", 2L)
    }
    opt$h1.information <- rep.int("unstructured", 2L) # FIXME: allow option?
  }


  # omega information
  if (opt$omega.information == "default") {
    opt$omega.information <- opt$information[2] # test version!
  }

  if (opt$omega.h1.information == "default") {
    # opt$omega.h1.information <- opt$h1.information[2] # test version!
    opt$omega.h1.information <- "unstructured"
  }

  if (opt$omega.h1.information.meat == "default") {
    opt$omega.h1.information.meat <- opt$omega.h1.information
  }

  # conditional.x
  if (is.character(opt$conditional.x)) { # = "default"
    if (opt$.categorical) {
      opt$conditional.x <- TRUE
    } else {
      opt$conditional.x <- FALSE
    }
  }

  # if conditional.x, always use a meanstructure
  if (opt$conditional.x) {
    opt$meanstructure <- TRUE
  }

  # fixed.x
  if (is.logical(opt$fixed.x)) {
    # if(opt$conditional.x && opt$fixed.x == FALSE && !opt$.multilevel) {
    if (opt$conditional.x && opt$fixed.x == FALSE) {
      lav_msg_stop(gettext(
        "fixed.x = FALSE is not supported when conditional.x = TRUE."
      ))
    }
    if (opt$fixed.x && is.character(opt$start) && opt$start == "simple") {
      lav_msg_warn(gettextf(
        "start = %s implies fixed.x = FALSE", dQuote(opt$start)
      ))
      opt$fixed.x <- FALSE
    }
  } else if (opt$fixed.x == "default") {
    if (opt$conditional.x) {
      opt$fixed.x <- TRUE
    } else {
      opt$fixed.x <- FALSE
    }
  }

  # meanstructure again
  if (any(opt$missing == c("ml", "ml.x")) || opt$model.type == "growth") {
    opt$meanstructure <- TRUE
  }
  if (any(c("intercepts", "means") %in% opt$group.equal)) {
    opt$meanstructure <- TRUE
  }
  # if(opt$se == "robust.huber.white" ||
  #   opt$se == "robust.sem" ||
  #   opt$test == "satorra.bentler" ||
  #   opt$test == "mean.var.adjusted" ||
  #   opt$test == "scaled.shifted" ||
  #   opt$test == "yuan.bentler") {
  #    opt$meanstructure <- TRUE
  # }
  if (!is.logical(opt$meanstructure)) {
    lav_msg_fixme("meanstructure must be logical at this point!")
  }

  # zero cell frequencies
  if (is.character(opt$zero.add)) { # = "default"
    opt$zero.add <- c(0.5, 0.0)
    # FIXME: TODO: mimic EQS , LISREL (0.0, 0.0)
  } else {
    if (length(opt$zero.add) == 1L) {
      opt$zero.add <- c(opt$zero.add, opt$zero.add)
    }
  }

  if (is.character(opt$zero.keep.margins)) { # = "default"
    opt$zero.keep.margins <- FALSE
  }


  # parameterization
  if (opt$parameterization == "default") {
    # for now, default is always delta
    opt$parameterization <- "delta"
  }

  # std.lv vs auto.fix.first # new in 0.6-5 (used to be in sem/cfa/growth)
  if (opt$std.lv) {
    opt$auto.fix.first <- FALSE
  }

  # std.lv vs effect.coding # new in 0.6-4
  if (is.logical(opt$effect.coding)) {
    if (opt$effect.coding) {
      opt$effect.coding <- c("loadings", "intercepts")
    } else {
      opt$effect.coding <- ""
    }
  }

  # if we use effect coding for the factor loadings, we don't need/want
  # std.lv = TRUE
  if (any("loadings" == opt$effect.coding)) {
    if (opt$std.lv) {
      lav_msg_stop(gettextf(
        "std.lv is set to FALSE but effect.coding contains %s",
        dQuote("loadings")
      ))
    }
    # shut off auto.fix.first
    opt$auto.fix.first <- FALSE
  }

  # test again

  # unless test = "none", always add test = "standard" as the
  # first entry
  # NO: this breaks lavaan.survey pval.pFsum, which has the following check:
  # if (!lavInspect(lavaan.fit, "options")$test %in% c("satorra.bentler",
  #    "mean.var.adjusted", "Satterthwaite")) {
  #    lav_msg_stop(
  #    gettext("Please refit the model with Satorra-Bentler (MLM)"),
  #    gettext(" or Satterthwaite (MLMVS) adjustment."))
  # }
  # if(! (length(opt$test) == 1L && opt$test == "none") ) {
  #    opt$test <- c("standard", opt$test)
  #    opt$test <- unique(opt$test)
  # }

  # add standard.test to test (if not already there)
  if (opt$standard.test != "standard") {
    if (length(opt$test) == 1L && opt$test[1] == "standard") {
      opt$test <- unique(c(opt$test, opt$standard.test))
    } else {
      opt$test <- unique(c(opt$standard.test, opt$test))
    }
  }

  # add scaled.test to test (if not already there)
  if (opt$scaled.test != "standard") {
    if (length(opt$test) == 1L && opt$test[1] == "standard") {
      opt$test <- unique(c(opt$test, opt$scaled.test))
    } else {
      opt$test <- unique(c(opt$scaled.test, opt$test))
    }
  }

  # where does "standard" appear in the opt$test vector?
  if (opt$test[1] != "none") {
    standard.idx <- which(opt$test == "standard")[1]
    if (is.na(standard.idx)) {
      # "standard" is not in the opt$test vector at all,
      # so add it
      opt$test <- c("standard", opt$test)
    } else if (length(standard.idx) > 0L && standard.idx != 1L) {
      # make sure "standard" comes first
      opt$test <- c("standard", opt$test[-standard.idx])
    }
  }

  # final check
  wrong.idx <- which(!opt$test %in% c(
    "none", "standard", "satorra.bentler",
    "yuan.bentler", "yuan.bentler.mplus",
    "mean.var.adjusted", "scaled.shifted",
    "browne.residual.adf", "browne.residual.nt",
    "browne.residual.nt.model",
    "browne.residual.adf.model",
    "bollen.stine"
  ))
  if (length(wrong.idx) > 0L) {
    lav_msg_stop(gettextf(
      "invalid option(s) for test argument: %1$s. Possible options are: %2$s.",
      lav_msg_view(opt$test[wrong.idx]),
      lav_msg_view(c(
        "none", "standard", "browne.residual.adf",
        "browne.residual.nt", "browne.residual.adf.model",
        "browne.residual.nt.model", "satorra.bentler",
        "yuan.bentler", "yuan.bentler.mplus",
        "mean.var.adjusted", "scaled.shifted",
        "bollen.stine"
      ), log.sep = "or")
    ))
  }

  # bounds
  if (is.null(opt$bounds)) {
    if (length(opt$optim.bounds) > 0L) {
      opt$bounds <- "user"
    } else {
      opt$bounds <- "none" # for now
    }
  } else if (is.logical(opt$bounds)) {
    if (opt$bounds) {
      opt$bounds <- "wide" # default for most estimators
    } else {
      opt$bounds <- "none"
    }
  }

  # optim.bounds
  if (length(opt$optim.bounds) > 0L) {
    # opt$bounds should be "default", or "user" (or "none")
    if (any(opt$bounds == c("default", "none", "user"))) {
      opt$bounds <- "user"
    } else {
      lav_msg_stop(
        gettext("bounds and optim.bounds arguments can not be used together;
                remove the bounds= argument or set it to \"user\".")
      )
    }
  }

  # handle different 'profiles'
  if (opt$bounds == "none") {
    opt$optim.bounds <- list(
      lower = character(0L),
      upper = character(0L)
    )
  } else if (opt$bounds == "user") {
    if (length(opt$optim.bounds) == 0L) {
      lav_msg_stop(gettextf(
        "bounds= is %s but optim.bounds= argument is empty", dQuote("user")
      ))
    }
  } else if (opt$bounds == "default" || opt$bounds == "wide") {
    opt$optim.bounds <- list(
      lower = c("ov.var", "lv.var", "loadings", "covariances"),
      upper = c("ov.var", "lv.var", "loadings", "covariances"),
      lower.factor = c(1.05, 1.0, 1.1, 1.0),
      upper.factor = c(1.20, 1.3, 1.1, 1.0),
      min.reliability.marker = 0.1,
      min.var.lv.endo = 0.005
    )
  } else if (opt$bounds == "wide.zerovar") {
    opt$optim.bounds <- list(
      lower = c("ov.var", "lv.var", "loadings", "covariances"),
      upper = c("ov.var", "lv.var", "loadings", "covariances"),
      lower.factor = c(1.00, 1.0, 1.1, 1.0),
      upper.factor = c(1.20, 1.3, 1.1, 1.0),
      min.reliability.marker = 0.1,
      min.var.lv.endo = 0.005
    )
  } else if (opt$bounds == "standard") {
    opt$optim.bounds <- list(
      lower = c("ov.var", "lv.var", "loadings", "covariances"),
      upper = c("ov.var", "lv.var", "loadings", "covariances"),
      lower.factor = c(1.0, 1.0, 1.0, 0.999),
      upper.factor = c(1.0, 1.0, 1.0, 0.999),
      min.reliability.marker = 0.1,
      min.var.lv.endo = 0.005
    )
  } else if (opt$bounds == "pos.var") {
    opt$optim.bounds <- list(
      lower = c("ov.var", "lv.var"),
      lower.factor = c(1, 1),
      min.reliability.marker = 0.0,
      min.var.lv.exo = 0.0,
      min.var.lv.endo = 0.0
    )
  } else if (opt$bounds == "pos.ov.var") {
    opt$optim.bounds <- list(
      lower = c("ov.var"),
      lower.factor = 1
    )
  } else if (opt$bounds == "pos.lv.var") {
    opt$optim.bounds <- list(
      lower = c("lv.var"),
      lower.factor = 1,
      min.reliability.marker = 0.0,
      min.var.lv.exo = 0.0,
      min.var.lv.endo = 0.0
    )
  }

  # rotations.args
  if (!is.list(opt$rotation.args)) {
    lav_msg_stop(gettext("rotation.args should be be list."))
  }

  # force orthogonal for some rotation algorithms
  if (any(opt$rotation == c(
    "varimax", "entropy", "mccammon",
    "tandem1", "tandem2"
  ))) {
    opt$rotation.args$orthogonal <- TRUE
  }

  # if target, check target matrix, and set order.lv.by to = "none"
  if (opt$rotation == "target.strict" || opt$rotation == "pst") {
    target <- opt$rotation.args$target
    if (is.null(target)) {
      lav_msg_stop(gettext("rotation target matrix is NULL"))
    }
    if (is.list(target)) {
      if (!all(sapply(target, is.matrix))) {
        lav_msg_stop(gettext("the target list contains
                              elements that are not a matrix"))
      }
    } else if (!is.matrix(target)) {
      lav_msg_stop(gettext("rotation target matrix is not a matrix"))
    }
    opt$rotation.args$order.lv.by <- "none"
  }

  if (opt$rotation == "pst") {
    target.mask <- opt$rotation.args$target.mask
    if (is.null(target.mask) || length(target.mask) == 0L) {
      # lav_msg_stop(gettext("rotation target.mask matrix is NULL"))
      if (is.matrix(target)) {
        tmp <- matrix(1L, nrow = nrow(target), ncol = ncol(target))
        tmp[target != 0] <- 0L # ignore these (non-zero) elements
        opt$rotation.args$target.mask <- target.mask <- tmp
      } else if (is.list(target)) {
        out <- lapply(seq_along(target), function(g) {
          tmp <- matrix(1L,
            nrow = nrow(target[[g]]),
            ncol = ncol(target[[g]])
          )
          tmp[target[[g]] != 0] <- 0L # ignore these (non-zero) elements
          tmp
        })
        opt$rotation.args$target.mask <- target.mask <- out
      }
    }
    if (is.list(target.mask)) {
      if (!all(sapply(target.mask, is.matrix))) {
        lav_msg_stop(gettext("the target.mask list contains
                              elements that are not a matrix"))
      }
    } else if (!is.matrix(target.mask)) {
      lav_msg_stop(gettext("rotation target.mask matrix is not a matrix"))
    }
    if (is.list(target) && !is.list(target.mask)) {
      lav_msg_stop(gettext("target is a list, but target.mask is not a list"))
    }
    if (is.list(target.mask) && !is.list(target)) {
      lav_msg_stop(gettext("target.mask is a list, but target is not a list"))
    }
    if (is.list(target) && is.list(target.mask)) {
      if (length(target) != length(target.mask)) {
        lav_msg_stop(gettext("length(target) != length(target.mask)"))
      }
    }
  }

  # if NAs, force opt$rotation to be 'pst' and create target.mask
  if (opt$rotation == "target.strict") {
    # matrix
    warn.flag <- FALSE
    if (is.matrix(target) && anyNA(target)) {
      warn.flag <- TRUE
      opt$rotation <- "pst"
      target.mask <- matrix(1, nrow = nrow(target), ncol = ncol(target))
      target.mask[is.na(target)] <- 0
      opt$rotation.args$target.mask <- target.mask

      # list
    } else if (is.list(target)) {
      ngroups <- length(target)
      for (g in seq_len(ngroups)) {
        if (anyNA(target[[g]])) {
          warn.flag <- TRUE
          # is target.mask just a <0 x 0 matrix>? create list!
          if (is.matrix(opt$rotation.args$target.mask)) {
            opt$rotation.args$target.mask <- vector("list", length = ngroups)
          }
          opt$rotation <- "pst"
          target.mask <- matrix(1,
            nrow = nrow(target[[g]]),
            ncol = ncol(target[[g]])
          )
          target.mask[is.na(target[[g]])] <- 0
          opt$rotation.args$target.mask[[g]] <- target.mask
        }
      }
    }
    if (warn.flag) {
      lav_msg_warn(gettext(
        "switching to PST rotation as target matrix contains NA values"
      ))
    }
  }

  # set row.weights
  opt$rotation.args$row.weights <- tolower(opt$rotation.args$row.weights)
  if (opt$rotation.args$row.weights == "default") {
    # the default is "none", except for varimax and promax
    if (any(opt$rotation == c("varimax", "promax"))) {
      opt$rotation.args$row.weights <- "kaiser"
    } else {
      opt$rotation.args$row.weights <- "none"
    }
  }

  # override if bifactor
  if (any(opt$rotation == c(
    "bi-geomin", "bigeomin", "bi-quartimin",
    "biquartimin"
  ))) {
    opt$rotation.args$order.lv.by <- "none"
  }

  # no standard errors for promax (for now)...
  if (opt$rotation == "promax") {
    opt$se <- "none"
    opt$rotation.args$algorithm <- "promax"
    opt$rotation.args$rstarts <- 0L
  }

  # correlation
  if (opt$correlation) {
    # standardize
    opt$std.ov <- TRUE
    # if ML, switch to GLS
    if (opt$estimator == "ml") {
      # lav_msg_warn(gettext(
      #        "GLS should be used for correlation structures instead of ML."))
      opt$estimator <- "gls"
    }
    if (opt$missing == "ml") {
      lav_msg_stop(gettext(
        "correlation structures only work for complete data (for now)."
      ))
    }
    if (opt$.multilevel) {
      lav_msg_stop(gettext(
        "correlation structures only work for single-level data."
      ))
    }
    if (opt$conditional.x) {
      lav_msg_stop(gettext(
        "correlation structures only work for conditional.x = FALSE (for now)."
      ))
    }
    if (opt$representation == "RAM") {
      lav_msg_stop(gettext(
        "correlation structures only work for representation = \"LISREL\"."
      ))
    }
    if (opt$fixed.x) {
      lav_msg_stop(gettext(
        "correlation structures only work for fixed.x = FALSE (for now)."
      ))
    }
  }

  # sample.cov.robust
  # new in 0.6-17
  # sample.cov.robust cannot be used if:
  # - data is missing (for now),
  # - sampling weights are used
  # - estimator is (D)WLS
  # - multilevel
  # - conditional.x
  if (opt$sample.cov.robust) {
    if (opt$missing != "listwise") {
      lav_msg_stop(gettext(
        "sample.cov.robust = TRUE does not work (yet) if data is missing."
      ))
    }
    if (opt$.categorical) {
      lav_msg_stop(gettext(
        "sample.cov.robust = TRUE does not work (yet) if data is categorical"
      ))
    }
    if (opt$.clustered || opt$.multilevel) {
      lav_msg_stop(gettext(
        "sample.cov.robust = TRUE does not work (yet) if data is clustered"
      ))
    }
    if (opt$conditional.x) {
      lav_msg_stop(gettext(
        "sample.cov.robust = TRUE does not work (yet) if conditional.x = TRUE"
      ))
    }
    if (all(lav_options_estimatorgroup(opt$estimator) != c("ML", "GLS"))) {
      lav_msg_stop(gettext(
        "sample.cov.robust = TRUE does not work (yet)
        if estimator is not GLS or ML"
      ))
    }
  }

  opt$estimator <- lav_options_estimatorgroup(opt$estimator)

  # group.w.free
  # if(opt$group.w.free && opt$.categorical) {
  #    lav_msg_stop(gettext(
  #    "group.w.free = TRUE is not supported (yet) in the categorical setting."
  #    ))
  # }

  # in order not to break semTools and blavaan, we restore categorical:
  opt$categorical <- opt$.categorical

  if (lav_debug()) {
    cat("lavaan DEBUG: lavaanOptions OUT\n")
    str(opt)
  }

  opt
}

#
# the lavData class describes how the data looks like
#  - do we have a full data frame, or only sample statistics?
#    (TODO: allow for patterns + freq, if data is categorical)
#  - variable type ("numeric", "ordered", ...)
#  - how many groups, how many observations, ...
#  - what about missing patterns?
#
# initial version: YR 14 April 2012

# YR 23 Feb 2017: blocks/levels/groups, but everything is group-based!

# FIXME: if nlevels > 1L, and ngroups > 1L, we should check that
# group is at the upper-level

# YR 08 May  2019: sampling weights normalization -> different options

# extract the data we need for this particular model
lav_lavdata <- function(data = NULL, # data.frame
                    group = NULL, # multiple groups?
                    cluster = NULL, # clusters?
                    ov.names = NULL, # variables in model
                    ov.names.x = character(0), # exo variables
                    ov.names.l = list(), # names per level
                    ordered = NULL, # ordered variables
                    sampling.weights = NULL, # sampling weights
                    sample.cov = NULL, # sample covariance(s)
                    sample.mean = NULL, # sample mean vector(s)
                    sample.th = NULL, # sample thresholds
                    sample.nobs = NULL, # sample nobs
                    lavoptions = lavOptions(), # lavoptions
                    allow.single.case = FALSE # for newdata in predict
) {
  # get info from lavoptions

  # group.labels
  group.label <- lavoptions$group.label
  if (is.null(group.label)) {
    group.label <- character(0L)
  }

  # level.labels
  level.label <- lavoptions$level.label
  if (is.null(level.label)) {
    level.label <- character(0L)
  }

  # allow empty categories of ordinal variable
  allow.empty.cell <- lavoptions$allow.empty.cell

  # block.labels
  block.label <- character(0L)
  if (length(group.label) > 0L && length(level.label) == 0L) {
    block.label <- group.label
  } else if (length(level.label) > 0L && length(group.label) == 0L) {
    block.label <- level.label
  } else if (length(group.label) > 0L &&
    length(level.label) > 0L) {
    block.label <- paste(rep(group.label, each = length(level.label)),
      rep(level.label, times = length(group.label)),
      sep = "."
    )
  }

  # std.ov?
  std.ov <- lavoptions$std.ov
  if (is.null(std.ov)) {
    std.ov <- FALSE
  }

  # missing? (lav_object_cor() does not parse options before calling lavdata...)
  missing <- tolower(lavoptions$missing)
  if (is.null(missing) || missing == "default") {
    missing <- "listwise"
  } else if (missing %in% c("ml", "fiml", "direct")) {
    missing <- "ml"
  } else if (missing %in% c("ml.x", "fiml.x", "direct.x")) {
    missing <- "ml.x"
  }

  # warn?
  if (allow.single.case) { # eg, in lavPredict
    current.warn <- lav_warn()
    if (lav_warn(FALSE))
        on.exit(lav_warn(current.warn), TRUE)
  }

  # four scenarios:
  #    0) data is already a lavData object: do nothing
  #    1) data is full data.frame (or a matrix)
  #    2) data are sample statistics only
  #    3) no data at all

  # 1) full data
  if (!is.null(data)) {
    # catch lavaan/lavData objects
    if (inherits(data, "lavData")) {
      return(data)
    } else if (inherits(data, "lavaan")) {
      return(data@Data)
    }

    # catch matrix
    if (!is.data.frame(data)) {
      # is it a matrix?
      if (is.matrix(data)) {
        if (nrow(data) == ncol(data)) {
          # perhaps it is a covariance matrix?
          if (isSymmetric(data)) {
            lav_msg_warn(
              gettext("data argument looks like a covariance matrix;
              please use the sample.cov argument instead"))
          }
        }
        # or perhaps it is a data matrix?
        ### FIXME, we should avoid as.data.frame() and handle
        ### data matrices directly
        data <- as.data.frame(data, stringsAsFactors = FALSE)
      } else {
        lav_msg_stop(gettextf(
          "data= argument is not a data.frame, but of class %s",
          sQuote(class(data))))
      }
    }

    # no ov.names?
    if (is.null(ov.names)) {
      ov.names <- names(data)
      # remove group variable, if provided
      if (length(group) > 0L) {
        group.idx <- which(ov.names == group)
        ov.names <- ov.names[-group.idx]
      }
      # remove cluster variable, if provided
      if (length(cluster) > 0L) {
        cluster.idx <- which(ov.names == cluster)
        ov.names <- ov.names[-cluster.idx]
      }
    }

    lavData <- lav_data_full(
      data = data,
      group = group,
      cluster = cluster,
      group.label = group.label,
      level.label = level.label,
      block.label = block.label,
      ov.names = ov.names,
      ordered = ordered,
      sampling.weights = sampling.weights,
      sampling.weights.normalization =
        lavoptions$sampling.weights.normalization,
      ov.names.x = ov.names.x,
      ov.names.l = ov.names.l,
      std.ov = std.ov,
      missing = missing,
      allow.single.case = allow.single.case,
      allow.empty.cell = allow.empty.cell
    )
    sample.cov <- NULL # not needed, but just in case
  }


  # 2) sample moments
  if (is.null(data) && !is.null(sample.cov)) {
    # for now: no levels!!
    nlevels <- 1L

    # we also need the number of observations (per group)
    if (is.null(sample.nobs)) {
      lav_msg_stop(gettext("please specify number of observations"))
    }

    # if a 'group' argument was provided, keep it -- new in 0.6-4
    if (is.null(group)) {
      group <- character(0L)
    } else if (is.character(group)) {
      # nothing to do, just store it
    } else {
      lav_msg_stop(gettext("group argument should be a string"))
    }

    # list?
    if (is.list(sample.cov)) {
      # multiple groups, multiple cov matrices
      if (!is.null(sample.mean)) {
        stopifnot(length(sample.mean) == length(sample.cov))
      }
      if (!is.null(sample.th)) {
        stopifnot(length(sample.th) == length(sample.cov))
      }
      # multiple groups, multiple cov matrices
      ngroups <- length(sample.cov)
      LABEL <- names(sample.cov)
      if (is.null(group.label) || length(group.label) == 0L) {
        if (is.null(LABEL)) {
          group.label <- paste("Group ", 1:ngroups, sep = "")
        } else {
          group.label <- LABEL
        }
      } else {
        if (is.null(LABEL)) {
          stopifnot(length(group.label) == ngroups)
        } else {
          # FIXME!!!!
          # check if they match
        }
      }
    } else {
      ngroups <- 1L
      group.label <- character(0)
      if (!is.matrix(sample.cov)) {
        lav_msg_stop(gettext(
          "sample.cov must be a matrix or a list of matrices"))
      }
      sample.cov <- list(sample.cov)
    }

    # get ov.names
    if (is.null(ov.names)) {
      ov.names <- lapply(sample.cov, row.names)
    } else if (!is.list(ov.names)) {
      # duplicate ov.names for each group
      tmp <- ov.names
      ov.names <- vector("list", length = ngroups)
      ov.names[1:ngroups] <- list(tmp)
    } else {
      if (length(ov.names) != ngroups) {
        lav_msg_stop(gettextf(
          "ov.names assumes %1$s groups; data contains %2$s groups",
          length(ov.names), ngroups))
      }
      # nothing to do
    }

    # handle ov.names.x
    if (!is.list(ov.names.x)) {
      tmp <- ov.names.x
      ov.names.x <- vector("list", length = ngroups)
      ov.names.x[1:ngroups] <- list(tmp)
    } else {
      if (length(ov.names.x) != ngroups) {
        lav_msg_stop(gettextf(
          "ov.names.x assumes %1$s groups; data contains %2$s groups",
          length(ov.names.x), ngroups))
      }
    }

    ov <- list()
    ov$name <- unique(unlist(c(ov.names, ov.names.x)))
    nvar <- length(ov$name)
    ov$idx <- rep(NA, nvar)
    ov$nobs <- rep(sum(unlist(sample.nobs)), nvar)
    ov$type <- rep("numeric", nvar)
    ov$nlev <- rep(0, nvar)
    # check for categorical
    if (!is.null(sample.th)) {
      th.idx <- attr(sample.th, "th.idx")
      if (is.list(th.idx)) {
        th.idx <- th.idx[[1]] ## FIRST group only (assuming same ths!)
      }
      if (any(th.idx > 0)) {
        TAB <- table(th.idx[th.idx > 0])
        ord.idx <- as.numeric(names(TAB))
        nlev <- as.integer(unname(TAB) + 1)
        ov$type[ord.idx] <- "ordered"
        ov$nlev[ord.idx] <- nlev
      }
    }

    # if std.ov = TRUE, give a warning (suggested by Peter Westfall)
    if (std.ov && !lavoptions$correlation) {
      lav_msg_warn(gettext(
        "std.ov argument is ignored if only sample statistics are provided."))
    }

    # check variances (new in 0.6-7)
    if (!allow.single.case) {
      for (g in seq_len(ngroups)) {
        VAR <- diag(sample.cov[[g]])
        # 1. finite?
        if (!all(is.finite(VAR))) {
          lav_msg_stop(gettext(
          "at least one variance in the sample covariance matrix is not finite."))
          }
        # 2. near zero (or negative)?
        if (any(VAR < .Machine$double.eps)) {
          lav_msg_stop(
            gettext("at least one variance in the sample covariance matrix is
            (near) zero or negative."))
        }
        # 3. very large?
        max.var <- max(VAR)
        if (max.var > 1000000) {
          lav_msg_warn(
            gettext("some observed variances in the sample covariance matrix
            are larger than 1000000."))
        }
      }
    }

    # block.labels
    block.label <- character(0L)
    if (length(group.label) > 0L && length(level.label) == 0L) {
      block.label <- group.label
    } else if (length(level.label) > 0L && length(group.label) == 0L) {
      block.label <- level.label
    } else if (length(group.label) > 0L &&
      length(level.label) > 0L) {
      block.label <- paste(rep(group.label, each = length(level.label)),
        rep(level.label, times = length(group.label)),
        sep = "."
      )
    }

    # construct lavData object
    lavData <- new("lavData",
      data.type = "moment",
      ngroups = ngroups,
      group = group,
      nlevels = 1L, # for now
      cluster = character(0L),
      group.label = group.label,
      level.label = character(0L),
      block.label = block.label,
      nobs = as.list(sample.nobs),
      norig = as.list(sample.nobs),
      ov.names = ov.names,
      ov.names.x = ov.names.x,
      ov.names.l = ov.names.l,
      ordered = as.character(ordered),
      weights = vector("list", length = ngroups),
      sampling.weights = character(0L),
      ov = ov,
      std.ov = FALSE,
      missing = "listwise",
      case.idx = vector("list", length = ngroups),
      Mp = vector("list", length = ngroups),
      Rp = vector("list", length = ngroups),
      Lp = vector("list", length = ngroups),
      X = vector("list", length = ngroups),
      eXo = vector("list", length = ngroups)
    )
  }

  # 3) data.type = "none":  both data and sample.cov are NULL
  if (is.null(data) && is.null(sample.cov)) {
    # clustered/multilevel? --> ov.names.l should be filled in
    if (length(ov.names.l) > 0L) {
      nlevels <- length(ov.names.l[[1]]) # we assume the same number
      # of levels in each group!

      # do we have a cluster argument? if not, create one
      if (is.null(cluster)) {
        if (nlevels == 2L) {
          cluster <- "cluster"
        } else {
          cluster <- paste0("cluster", seq_len(nlevels - 1L))
        }
      }

      # default level.labels
      if (length(level.label) == 0L) {
        level.label <- c("within", cluster)
      } else {
        # check if length(level.label) = 1 + length(cluster)
        if (length(level.label) != length(cluster) + 1L) {
          lav_msg_stop(gettext("length(level.label) != length(cluster) + 1L"))
        }
        # nothing to do
      }
    } else {
      nlevels <- 1L
      cluster <- character(0L)
      level.label <- character(0L)
    }

    # ngroups: ov.names (when group: is used), or sample.nobs
    if (is.null(ov.names)) {
      lav_msg_warn(gettext("ov.names is NULL"))
      ov.names <- character(0L)
      if (is.null(sample.nobs)) {
        ngroups <- 1L
        sample.nobs <- rep(list(0L), ngroups)
      } else {
        sample.nobs <- as.list(sample.nobs)
        ngroups <- length(sample.nobs)
      }
    } else if (!is.list(ov.names)) {
      if (is.null(sample.nobs)) {
        ngroups <- 1L
        sample.nobs <- rep(list(0L), ngroups)
      } else {
        sample.nobs <- as.list(sample.nobs)
        ngroups <- length(sample.nobs)
      }
      ov.names <- rep(list(ov.names), ngroups)
    } else if (is.list(ov.names)) {
      ngroups <- length(ov.names)
      if (is.null(sample.nobs)) {
        sample.nobs <- rep(list(0L), ngroups)
      } else {
        sample.nobs <- as.list(sample.nobs)
        if (length(sample.nobs) != ngroups) {
          lav_msg_stop(gettextf(
            "length(sample.nobs) = %1$s but syntax implies ngroups = %2$s",
            length(sample.nobs), ngroups))
        }
      }
    }


    # group.label
    if (ngroups > 1L) {
      if (is.null(group)) {
        group <- "group"
      }
      group.label <- paste("Group", 1:ngroups, sep = "")
    } else {
      group <- character(0L)
      group.label <- character(0L)
    }

    # handle ov.names.x
    if (!is.list(ov.names.x)) {
      ov.names.x <- rep(list(ov.names.x), ngroups)
    }

    ov <- list()
    ov$name <- unique(unlist(c(ov.names, ov.names.x)))
    nvar <- length(ov$name)
    ov$idx <- rep(NA, nvar)
    ov$nobs <- rep(0L, nvar)
    ov$type <- rep("numeric", nvar)
    ov$nlev <- rep(0L, nvar)

    # collect information per upper-level group
    Lp <- vector("list", length = ngroups)
    for (g in 1:ngroups) {
      if (nlevels > 1L) {
        # ALWAYS add ov.names.x at the end, even if conditional.x
        OV.NAMES <- unique(c(ov.names[[g]], ov.names.x[[g]]))
        Lp[[g]] <- lav_data_cluster_patterns(
          Y = NULL, clus = NULL,
          cluster = cluster,
          multilevel = TRUE,
          ov.names = OV.NAMES,
          ov.names.x = ov.names.x[[g]],
          ov.names.l = ov.names.l[[g]]
        )
      }
    } # g

    # block.labels
    block.label <- character(0L)
    if (length(group.label) > 0L && length(level.label) == 0L) {
      block.label <- group.label
    } else if (length(level.label) > 0L && length(group.label) == 0L) {
      block.label <- level.label
    } else if (length(group.label) > 0L &&
      length(level.label) > 0L) {
      block.label <- paste(rep(group.label, each = length(level.label)),
        rep(level.label, times = length(group.label)),
        sep = "."
      )
    }

    # construct lavData object
    lavData <- new("lavData",
      data.type = "none",
      ngroups = ngroups,
      group = group,
      nlevels = nlevels,
      cluster = cluster,
      group.label = group.label,
      level.label = level.label,
      block.label = block.label,
      nobs = sample.nobs,
      norig = sample.nobs,
      ov.names = ov.names,
      ov.names.x = ov.names.x,
      ov.names.l = ov.names.l,
      ordered = as.character(ordered),
      weights = vector("list", length = ngroups),
      sampling.weights = character(0L),
      ov = ov,
      missing = "listwise",
      case.idx = vector("list", length = ngroups),
      Mp = vector("list", length = ngroups),
      Rp = vector("list", length = ngroups),
      Lp = Lp,
      X = vector("list", length = ngroups),
      eXo = vector("list", length = ngroups)
    )
  }

  lavData
}


# handle full data
lav_data_full <- function(data = NULL, # data.frame
                          group = NULL, # multiple groups?
                          cluster = NULL, # clustered?
                          group.label = NULL, # custom group labels?
                          level.label = NULL,
                          block.label = NULL,
                          ov.names = NULL, # variables needed
                          # in model
                          ordered = NULL, # ordered variables
                          sampling.weights = NULL, # sampling weights
                          sampling.weights.normalization = "none",
                          ov.names.x = character(0L), # exo variables
                          ov.names.l = list(), # var per level
                          std.ov = FALSE, # standardize ov's?
                          missing = "listwise", # remove missings?
                          allow.single.case = FALSE, # allow single case?
                          allow.empty.cell = FALSE
) {
  # number of groups and group labels
  if (!is.null(group) && length(group) > 0L) {
    if (!(group %in% names(data))) {
      lav_msg_stop(gettextf(
        "grouping variable %1$s not found; variable names
        found in data frame are: %2$s",
        sQuote(group),paste(names(data), collapse = " ")))
    }
    # note: by default, we use the order as in the data;
    # not as in levels(data[,group])
    if (length(group.label) == 0L) {
      group.label <- unique(as.character(data[[group]]))
      if (any(is.na(group.label))) {
        lav_msg_warn(gettextf("group variable %s contains missing values",
                              sQuote(group)))
      }
      group.label <- group.label[!is.na(group.label)]
    } else {
      group.label <- unique(as.character(group.label))
      # check if user-provided group labels exist
      LABEL <- unique(as.character(data[[group]]))
      idx <- match(group.label, LABEL)
      if (any(is.na(idx))) {
        lav_msg_warn(gettextf(
          "some group.labels do not appear in the grouping variable: %s",
          lav_msg_view(group.label[which(is.na(idx))], log.sep = "none"))
        )
      }
      group.label <- group.label[!is.na(idx)]
      # any groups left?
      if (length(group.label) == 0L) {
        lav_msg_stop(gettext(
          "no group levels left; check the group.label argument"))
      }
    }
    ngroups <- length(group.label)
  } else {
    if (length(group.label) > 0L) {
      lav_msg_warn(gettext(
       "`group.label' argument will be ignored if `group' argument is missing"))
    }
    ngroups <- 1L
    group.label <- character(0L)
    group <- character(0L)
  }

  # ensure allow.empty.cell is logical
  if (is.null(allow.empty.cell)) allow.empty.cell <- FALSE

  # sampling weights
  if (!is.null(sampling.weights)) {
    if (is.character(sampling.weights)) {
      if (!(sampling.weights %in% names(data))) {
        lav_msg_stop(
          gettextf("sampling weights variable %1$s not found;
                   variable names found in data frame are: %2$s",
          sQuote(sampling.weights), paste(names(data), collapse = " ")))
      }
      # check for missing values in sampling weight variable
      if (any(is.na(data[[sampling.weights]]))) {
        lav_msg_stop(
          gettextf("sampling.weights variable %s contains missing values",
          sQuote(sampling.weights)))
      }
    } else {
      lav_msg_stop(gettext(
        "sampling weights argument should be a variable name in the data.frame"
        ))
    }
  }

  # clustered?
  if (!is.null(cluster) && length(cluster) > 0L) {
    # cluster variable in data?
    if (!all(cluster %in% names(data))) {
      # which one did we not find?
      not.ok <- which(!cluster %in% names(data))
      lav_msg_stop(gettextf(
        "cluster variable(s) %1$s not found;
        variable names found in data frame are: %2$s",
        sQuote(cluster[not.ok]), paste(names(data), collapse = " ")))
    }

    # check for missing values in cluster variable(s)
    for (cl in 1:length(cluster)) {
      if (anyNA(data[[cluster[cl]]])) {
        lav_msg_warn(gettextf("cluster variable %s contains missing values",
          sQuote(cluster[cl])))
      }
    }

    # multilevel?
    if (length(ov.names.l) > 0L) {
      # default level.labels
      if (length(level.label) == 0L) {
        level.label <- c("within", cluster)
      } else {
        # check if length(level.label) = 1 + length(cluster)
        if (length(level.label) != length(cluster) + 1L) {
          lav_msg_stop(gettext("length(level.label) != length(cluster) + 1L"))
        }
        # nothing to do
      }
      nlevels <- length(level.label)
    } else {
      # just clustered data, but no random effects
      nlevels <- 1L
      level.label <- character(0L)
    }
  } else {
    if (length(level.label) > 0L) {
      lav_msg_warn(gettext(
       "`level.label' argument will be ignored if `cluster' argument is missing"
      ))
    }
    nlevels <- 1L
    level.label <- character(0L)
    cluster <- character(0L)
  }

  # check ov.names vs ngroups
  if (ngroups > 1L) {
    if (is.list(ov.names)) {
      if (length(ov.names) != ngroups) {
        lav_msg_stop(gettextf(
          "ov.names assumes %1$s groups; data contains %2$s groups",
          length(ov.names), ngroups))
      }
    } else {
      tmp <- ov.names
      ov.names <- vector("list", length = ngroups)
      ov.names[1:ngroups] <- list(tmp)
    }
    if (is.list(ov.names.x)) {
      if (length(ov.names.x) != ngroups) {
        lav_msg_stop(gettextf(
          "ov.names.x assumes %1$s groups; data contains %2$s groups",
          length(ov.names.x), ngroups))
      }
    } else {
      tmp <- ov.names.x
      ov.names.x <- vector("list", length = ngroups)
      ov.names.x[1:ngroups] <- list(tmp)
    }
  } else {
    if (is.list(ov.names)) {
      if (length(ov.names) > 1L) {
        lav_msg_stop(gettext(
          "model syntax defines multiple groups; data suggests a single group"))
      }
    } else {
      ov.names <- list(ov.names)
    }
    if (is.list(ov.names.x)) {
      if (length(ov.names.x) > 1L) {
        lav_msg_stop(gettext(
          "model syntax defines multiple groups; data suggests a single group"))
      }
    } else {
      ov.names.x <- list(ov.names.x)
    }
  }

  # check if all ov.names can be found in the data.frame
  for (g in 1:ngroups) {
    # does the data contain all the observed variables
    # needed in the user-specified model for this group
    ov.all <- unique(c(ov.names[[g]], ov.names.x[[g]])) # no overlap if categ

    # handle interactions
    ov.int.names <- ov.all[grepl(":", ov.all)]
    n.int <- length(ov.int.names)
    if (n.int > 0L) {
      ov.names.noint <- ov.all[!ov.all %in% ov.int.names]
      for (iv in seq_len(n.int)) {
        NAMES <- strsplit(ov.int.names[iv], ":", fixed = TRUE)[[1L]]
        if (all(NAMES %in% ov.names.noint)) {
          # add this interaction term to the data.frame, unless
          # it already exists
          if (is.null(data[[ov.int.names[iv]]])) {
            data[[ov.int.names[iv]]] <-
              data[[NAMES[1L]]] * data[[NAMES[2L]]]
          }
        }
      }
    }

    # check for missing observed variables
    idx.missing <- which(!(ov.all %in% names(data)))

    if (length(idx.missing)) {
      lav_msg_stop(
        gettextf("some (observed) variables specified in the model are
        not found in the dataset: %s",
        paste(ov.all[idx.missing], collapse = " ")))
    }
  }


  # here, we know for sure all ov.names exist in the data.frame
  # create varTable
  # FIXME: should we add the 'group'/'cluster' variable (no for now)
  ov <- lav_dataframe_vartable(
    frame = data, ov.names = ov.names,
    ov.names.x = ov.names.x, ordered = ordered,
    as.data.frame. = FALSE, allow.empty.cell = allow.empty.cell
  )

  # do some checking
  # check for unordered factors (but only if nlev > 2)
  if ("factor" %in% ov$type) {
    f.names <- ov$name[ov$type == "factor" & ov$nlev > 2L]
    f.names.all <- ov$name[ov$type == "factor"]
    OV.names <- unlist(ov.names)
    OV.names.x <- unlist(ov.names.x)
    OV.names.nox <- OV.names[!OV.names %in% OV.names.x]
    if (any(f.names %in% OV.names.x)) {
      lav_msg_stop(
        gettext("unordered factor(s) with more than 2 levels detected
            as exogenous covariate(s): "),
        paste(f.names, collapse = " "))
    } else if (any(f.names.all %in% OV.names.nox)) {
      lav_msg_stop(
        gettext("unordered factor(s) detected; make them numeric or ordered:"),
        paste(f.names.all, collapse = " "))
    }
  }
  # check for ordered exogenous variables
  if ("ordered" %in% ov$type[ov$name %in% unlist(ov.names.x)]) {
    f.names <- ov$name[ov$type == "ordered" &
      ov$name %in% unlist(ov.names.x)]
    if (any(f.names %in% unlist(ov.names.x))) {
      lav_msg_warn(gettextf(
        "exogenous variable(s) declared as ordered in data: %s",
        lav_msg_view(f.names, log.sep = "none")))
    }
  }
  # check for ordered endogenous variables with more than 12 levels
  if ("ordered" %in% ov$type[!ov$name %in% unlist(ov.names.x)]) {
    f.names <- ov$name[ov$type == "ordered" &
      !ov$name %in% unlist(ov.names.x) &
      ov$nlev > 12L]
    if (length(f.names) > 0L) {
      lav_msg_warn(gettextf(
        "some ordered categorical variable(s) have more than 12 levels: %s",
        lav_msg_view(f.names, log.sep = "none")))
    }
  }
  # check for zero-cases
  idx <- which(ov$nobs == 0L | ov$var == 0)
  if (!allow.single.case && length(idx) > 0L) {
    OV <- as.data.frame(ov)
    rn <- rownames(OV)
    rn[idx] <- paste(rn[idx], "***", sep = "")
    rownames(OV) <- rn
    print(OV)
    lav_msg_stop(gettext(
      "some variables have no values (only missings) or no variance"))
  }
  # check for single cases (no variance!)
  idx <- which(ov$nobs == 1L | (ov$type == "numeric" & !is.finite(ov$var)))
  if (!allow.single.case && length(idx) > 0L) {
    OV <- as.data.frame(ov)
    rn <- rownames(OV)
    rn[idx] <- paste(rn[idx], "***", sep = "")
    rownames(OV) <- rn
    print(OV)
    lav_msg_stop(gettext(
      "some variables have only 1 observation or no finite variance"))
  }
  # check for ordered variables with only 1 level
  idx <- which(ov$type == "ordered" & ov$nlev == 1L)
  if (!allow.single.case && length(idx) > 0L) {
    OV <- as.data.frame(ov)
    rn <- rownames(OV)
    rn[idx] <- paste(rn[idx], "***", sep = "")
    rownames(OV) <- rn
    print(OV)
    lav_msg_stop(gettext("ordered variable(s) has/have only 1 level"))
  }
  # check for mix small/large variances (NOT including exo variables)
  if (!std.ov && !allow.single.case && any(ov$type == "numeric")) {
    num.idx <- which(ov$type == "numeric" & ov$exo == 0L)
    if (length(num.idx) > 0L) {
      min.var <- min(ov$var[num.idx])
      max.var <- max(ov$var[num.idx])
      rel.var <- max.var / min.var
      if (rel.var > 1000) {
        lav_msg_warn(
          gettext("some observed variances are (at least) a factor 1000 times
           larger than others; use varTable(fit) to investigate"))
      }
    }
  }
  # check for really large variances (perhaps -999999 for missing?)
  if (!allow.single.case && !std.ov && any(ov$type == "numeric")) {
    num.idx <- which(ov$type == "numeric" & ov$exo == 0L)
    if (length(num.idx) > 0L) {
      max.var <- max(ov$var[num.idx])
      if (max.var > 1000000) {
        lav_msg_warn(
          gettext("some observed variances are larger than 1000000
          use varTable(fit) to investigate"))
      }
    }
  }
  # check for all-exogenous variables (eg in f <~ x1 + x2 + x3)
  if (all(ov$exo == 1L)) {
    lav_msg_warn(gettext(
      "all observed variables are exogenous; model may not be identified"))
  }
  # check for perfect correlations (NOT including exo variables)
  if (!allow.single.case && any(ov$type == "numeric")) {
    num.idx <- which(ov$type == "numeric" & ov$exo == 0L)
    COR <- try(cor(data[,ov$idx[num.idx]], use = "pairwise.complete.obs"),
               silent = TRUE)
    # replace any NAs by 0 (as we only wish to detect perfect correlations)
    COR[is.na(COR)] <- 0
    if (!inherits(COR, "try-error") &&
        any(lav_matrix_vech(COR, diagonal = FALSE) == 1)) {
      COR[upper.tri(COR, diag = TRUE)] <- 0
      idx <- which(COR == 1)
      this.names <- ov$name[num.idx]
      bad.names <- this.names[ sort(unique(c(row(COR)[idx], col(COR)[idx]))) ]
      # should we make this a hard stop? things will most likely fail later...
      lav_msg_warn(gettextf(
      "some observed variables are perfectly correlated;
       please check your data; variables involved are: %s",
       paste(bad.names, collapse = " ")))
    }
  }

  # prepare empty lists

  # group-based
  case.idx <- vector("list", length = ngroups)
  Mp <- vector("list", length = ngroups)
  Rp <- vector("list", length = ngroups)
  norig <- vector("list", length = ngroups)
  nobs <- vector("list", length = ngroups)
  X <- vector("list", length = ngroups)
  eXo <- vector("list", length = ngroups)
  Lp <- vector("list", length = ngroups)
  weights <- vector("list", length = ngroups)

  # collect information per upper-level group
  # datam <- data.matrix(data) # YR: not yet, this breaks the stuart package!
  for (g in 1:ngroups) {
    # extract variables in correct order
    if (nlevels > 1L) {
      # keep 'joint' (Y,X) matrix in @X if multilevel (or always?)
      # yes for multilevel (for now); no for clustered only
      OV.NAMES <- unique(c(ov.names[[g]], ov.names.x[[g]]))
      ov.idx <- ov$idx[match(OV.NAMES, ov$name)]
    } else {
      ov.idx <- ov$idx[match(ov.names[[g]], ov$name)]
    }
    exo.idx <- ov$idx[match(ov.names.x[[g]], ov$name)]
    all.idx <- unique(c(ov.idx, exo.idx))

    # extract cases per group
    if (ngroups > 1L || length(group.label) > 0L) {
      if (missing == "listwise") {
        case.idx[[g]] <- which(data[[group]] == group.label[g] &
          complete.cases(data[all.idx]))
        nobs[[g]] <- length(case.idx[[g]])
        norig[[g]] <- length(which(data[[group]] == group.label[g]))
        # check for empty data
        if (nobs[[g]] == 0L) {
          lav_msg_stop(gettextf("all observations were deleted due to missing
                                 data after listwise deletion in group [%s];
                                 check your data
                                 or consider a different option for the missing=                                 argument.", group.label[g]))
        }
        # } else if(missing == "pairwise" && length(exo.idx) > 0L) {
        #    case.idx[[g]] <- which(data[[group]] == group.label[g] &
        #                           complete.cases(data[exo.idx]))
        #    nobs[[g]] <- length(case.idx[[g]])
        #    norig[[g]] <- length(which(data[[group]] == group.label[g]))
      } else if (length(exo.idx) > 0L && missing != "ml.x") {
        case.idx[[g]] <- which(data[[group]] == group.label[g] &
          complete.cases(data[exo.idx]))
        nobs[[g]] <- length(case.idx[[g]])
        norig[[g]] <- length(which(data[[group]] == group.label[g]))
        if ((nobs[[g]] < norig[[g]])) {
          lav_msg_warn(gettextf(
              "%1$s cases were deleted in group %2$s  due to missing values
              in  exogenous variable(s), while fixed.x = TRUE.",
              (norig[[g]] - nobs[[g]]), group.label[g]))
        }
      } else {
        case.idx[[g]] <- which(data[[group]] == group.label[g])
        nobs[[g]] <- norig[[g]] <- length(case.idx[[g]])
      }
    } else {
      if (missing == "listwise") {
        case.idx[[g]] <- which(complete.cases(data[all.idx]))
        nobs[[g]] <- length(case.idx[[g]])
        norig[[g]] <- nrow(data)
        if (nobs[[g]] == 0L) {
          lav_msg_stop(gettext("all observations were deleted due to missing
                                data after listwise deletion;
                                check your data
                                or consider a different option for the missing=                                 argument."))
        }
        # } else if(missing == "pairwise" && length(exo.idx) > 0L) {
        #    case.idx[[g]] <- which(complete.cases(data[exo.idx]))
        #    nobs[[g]] <- length(case.idx[[g]])
        #    norig[[g]] <- nrow(data)
      } else if (length(exo.idx) > 0L && missing != "ml.x") {
        case.idx[[g]] <- which(complete.cases(data[exo.idx]))
        nobs[[g]] <- length(case.idx[[g]])
        norig[[g]] <- nrow(data)
        if ((nobs[[g]] < norig[[g]])) {
          lav_msg_warn(
            gettextf("%s cases were deleted due to missing values in
                     exogenous variable(s), while fixed.x = TRUE.",
                     (norig[[g]] - nobs[[g]])))
        }
      } else {
        case.idx[[g]] <- 1:nrow(data)
        nobs[[g]] <- norig[[g]] <- length(case.idx[[g]])
      }
    }

    # extract data
    #X[[g]] <- datam[case.idx[[g]], ov.idx, drop = FALSE]
    X[[g]] <- data.matrix(data[case.idx[[g]], ov.idx, drop = FALSE])
    dimnames(X[[g]]) <- NULL ### copy?

    # sampling weights (but no normalization yet)
    if (!is.null(sampling.weights)) {
      WT <- data[[sampling.weights]][case.idx[[g]]]
      if (any(WT < 0)) {
        lav_msg_stop(gettext("some sampling weights are negative"))
      }

      # check for missing values in sampling weight variable
      if (any(is.na(WT))) {
        lav_msg_stop(gettextf(
          "sampling.weights variable %s contains missing values",
          sQuote(sampling.weights)))
      }

      weights[[g]] <- WT
    }

    # construct integers for user-declared 'ordered' factors
    # FIXME: is this really (always) needed???
    #  (but still better than doing lapply(data[,idx], ordered) which
    #   generated even more copies)
    user.ordered.names <- ov$name[ov$type == "ordered" & ov$user == 1L]
    user.ordered.idx <- which(ov.names[[g]] %in% user.ordered.names)
    if (length(user.ordered.idx) > 0L) {
      for (i in user.ordered.idx) {
        X[[g]][, i][is.na(X[[g]][, i])] <- NA # change NaN to NA
        if (!allow.empty.cell) X[[g]][, i] <- as.numeric(as.factor(X[[g]][, i]))
        # possible alternative to the previous two lines:
        # X[[g]][,i] <- as.numeric(factor(X[[g]][,i], exclude = c(NA, NaN)))
      }
    }

    ## FIXME:
    ## - why also in X? (for samplestats, for now)
    if (length(exo.idx) > 0L) {
      eXo[[g]] <- data.matrix(data[case.idx[[g]], exo.idx, drop = FALSE])
      dimnames(eXo[[g]]) <- NULL
    } else {
      eXo[g] <- list(NULL)
    }

    # standardize observed variables? numeric only!
    if (std.ov) {
      num.idx <- which(ov$name %in% ov.names[[g]] &
        ov$type == "numeric" & ov$exo == 0L)
      if (length(num.idx) > 0L) {
        X[[g]][, num.idx] <-
          scale(X[[g]][, num.idx, drop = FALSE])[, , drop = FALSE]
        # three copies are made!!!!!
      }
      if (length(exo.idx) > 0L) {
        eXo[[g]] <- scale(eXo[[g]])[, , drop = FALSE]
      }
    }

    # response patterns (ordered variables only)
    ord.idx <- which(ov.names[[g]] %in% ov$name[ov$type == "ordered"])
    if (length(ord.idx) > 0L) {
      Rp[[g]] <- lav_data_resp_patterns(X[[g]][, ord.idx, drop = FALSE])
    }

    # warn if we have a small number of observations (but NO error!)
    if (!allow.single.case &&
      nobs[[g]] < (nvar <- length(ov.idx))) {
      txt <- ""
      if (ngroups > 1L) txt <- gettextf("in group %s", g)
      lav_msg_warn(
        gettextf("small number of observations (nobs < nvar) %1$s:
                 nobs = %2$s  nvar = %3$s", txt, nobs[[g]], nvar))
    }
    # check variances per group (if we have multiple groups)
    # to catch zero-variance variables within a group (new in 0.6-8)
    if (ngroups > 1L && !allow.empty.cell) {
      # X
      group.var <- apply(X[[g]], 2, var, na.rm = TRUE)
      zero.var <- which(group.var < .Machine$double.eps)
      if (length(zero.var) == 0L) {
        # all is good
      } else {
        # some zero variances!
        gtxt <- if (ngroups > 1L) {
          gettextf("in group %s", g)
        } else {
          ""
        }
       lav_msg_stop(
          gettext("some variables have no variance"), gtxt,
          ":", paste(ov.names[[g]][zero.var], collapse = " "))
      }

      # eXo (if conditional.x = TRUE)...
      if (length(exo.idx) > 0L) {
        group.var <- apply(eXo[[g]], 2, var, na.rm = TRUE)
        zero.var <- which(group.var < .Machine$double.eps)
        if (length(zero.var) == 0L) {
          # all is good
        } else {
          # some zero variances!
          gtxt <- if (ngroups > 1L) {
            gettextf("in group %s", g)
          } else {
            ""
          }
          lav_msg_stop(
            gettext("some exogenous variables have no variance"), gtxt,
            ":", paste(ov.names.x[[g]][zero.var], collapse = " ")
          )
        }
      }
    }

    # cluster information
    if (length(cluster) > 0L) {
      # extract cluster variable(s), for this group
      clus <- data.matrix(data[case.idx[[g]], cluster])
      if (nlevels > 1L) {
        multilevel <- TRUE
      } else {
        multilevel <- FALSE
      }
      # ALWAYS add ov.names.x at the end, even if conditional.x (0.6-7)
      OV.NAMES <- unique(c(ov.names[[g]], ov.names.x[[g]]))
      Lp[[g]] <- lav_data_cluster_patterns(
        Y = X[[g]], clus = clus,
        cluster = cluster,
        multilevel = multilevel,
        ov.names = OV.NAMES,
        ov.names.x = ov.names.x[[g]],
        ov.names.l = ov.names.l[[g]]
      )

      # new in 0.6-4
      # check for 'level-1' variables with zero within variance
      l1.idx <- c(
        Lp[[g]]$within.idx[[2]], # within only
        Lp[[g]]$both.idx[[2]]
      )
      for (v in l1.idx) {
        within.var <- tapply(X[[g]][, v], Lp[[g]]$cluster.idx[[2]],
          FUN = var, na.rm = TRUE
        )
        # ignore singletons
        singleton.idx <- which(Lp[[g]]$cluster.size[[2]] == 1L)
        if (length(singleton.idx) > 0L) {
          within.var[singleton.idx] <- 10 # non-zero variance
        }
        zero.var <- which(within.var < .Machine$double.eps)
        if (length(zero.var) == 0L) {
          # all is good
        } else if (length(zero.var) == length(within.var)) {
          # all zero! possibly a between-level variable
          gtxt <- if (ngroups > 1L) {
            gettextf("in group %s", g)
          } else {
            ""
          }
          lav_msg_warn(
            gettextf("Level-1 variable %1$s has no variance at the within
                     level %2$s. The variable appears to be a between-level
                     variable. Please remove this variable from the level 1
                     section in the model syntax.",
                     dQuote(ov.names[[g]][v]), gtxt))
        } else {
          # some zero variances!
          gtxt <- if (ngroups > 1L) {
            gettextf("in group %s", g)
          } else {
            ""
          }
          lav_msg_warn(gettextf(
          "Level-1 variable %1$s has no variance within some clusters %2$s.
          The cluster ids with zero within variance are: %3$s.",
          dQuote(ov.names[[g]][v]), gtxt,
          lav_msg_view(Lp[[g]]$cluster.id[[2]][zero.var], "none")))
        }
      }

      # new in 0.6-4
      # check for 'level-2' only variables with non-zero within variance
      l2.idx <- Lp[[g]]$between.idx[[2]] # between only
      error.flag <- FALSE
      for (v in l2.idx) {
        within.var <- tapply(X[[g]][, v], Lp[[g]]$cluster.idx[[2]],
          FUN = var, na.rm = TRUE
        )
        non.zero.var <- which(unname(within.var) > .Machine$double.eps)
        if (length(non.zero.var) == 0L) {
          # all is good
        } else if (length(non.zero.var) == 1L) {
          # just one
          gtxt <- if (ngroups > 1L) {
            gettextf("in group %s.", g)
          } else {
            "."
          }
          lav_msg_warn(gettextf(
            "Level-2 variable %1$ss has non-zero variance at the within
            level %2$s in one cluster with id: %3$ss. Please double-check
            if this is a between only variable.",
            dQuote(ov.names[[g]][v]), gtxt,
            Lp[[g]]$cluster.id[[2]][non.zero.var]))
        } else {
          error.flag <- TRUE
          # several
          gtxt <- if (ngroups > 1L) {
            gettextf("in group %s", g)
          } else {
            ""
          }
          lav_msg_warn(gettextf(
            "Level-2 variable %1$s has non-zero variance at the within level
            %2$s. The cluster ids with non-zero within variance are: %3$s",
            dQuote(ov.names[[g]][v]), gtxt,
            lav_msg_view(Lp[[g]]$cluster.id[[2]][non.zero.var], "none")))
        }
      }
      if (error.flag) {
        lav_msg_stop(
          gettext("Some between-level (only) variables have
          non-zero variance at the within-level.
          Please double-check your data.")
        )
      }
    } # clustered data

    # missing data
    if (missing != "listwise") {
      if (length(cluster) > 0L) {
        # get missing patterns
        Mp[[g]] <- lav_data_missing_patterns(X[[g]],
          sort.freq = TRUE, coverage = TRUE,
          Lp = Lp[[g]]
        )
      } else {
        # get missing patterns
        Mp[[g]] <- lav_data_missing_patterns(X[[g]],
          sort.freq = TRUE, coverage = TRUE,
          Lp = NULL
        )
      }

      # checking!
      if (length(Mp[[g]]$empty.idx) > 0L) {
        # new in 0.6-4: return 'original' index in full data.frame
        empty.case.idx <- case.idx[[g]][Mp[[g]]$empty.idx]
        lav_msg_warn(gettextf(
          "some cases are empty and will be ignored: %s.",
          paste(empty.case.idx, collapse = " ")))
      }
	  if (any(Mp[[g]]$coverage < 0.1)) {
	    coverage.vech <- lav_matrix_vech(Mp[[g]]$coverage, diagonal = FALSE)
	    small.idx <- which(coverage.vech < 0.1)
	    if (all(coverage.vech[small.idx] == 0)) {
		  # 0.6-18: no warning --> this could be due to missing by design
          # 0.6-20: give warning anyway (as EM is ignoring this)
          lav_msg_warn(gettext(
            "due to missing values, some pairwise combinations have zero
             coverage; the corresponding covariances are not identified;
             use lavInspect(fit, \"coverage\") to investigate."))
		} else {
          lav_msg_warn(gettext(
            "due to missing values, some pairwise combinations have less than
            10% coverage; use lavInspect(fit, \"coverage\") to investigate."))
	    }
      }
      # in case we had observations with only missings
      nobs[[g]] <- NROW(X[[g]]) - length(Mp[[g]]$empty.idx)
    } # missing
  } # groups, at first level

  # sampling weigths, again
  if (is.null(sampling.weights)) {
    sampling.weights <- character(0L)
  } else {
    # check if we need normalization
    if (sampling.weights.normalization == "none") {
      # nothing to do
    } else if (sampling.weights.normalization == "total") {
      sum.weights <- sum(unlist(weights))
      ntotal <- sum(unlist(nobs))
      for (g in 1:ngroups) {
        WT <- weights[[g]]
        WT2 <- WT / sum.weights * ntotal
        weights[[g]] <- WT2
      }
    } else if (sampling.weights.normalization == "group") {
      for (g in 1:ngroups) {
        WT <- weights[[g]]
        WT2 <- WT / sum(WT) * nobs[[g]]
        weights[[g]] <- WT2
      }
    } else {
      lav_msg_stop(gettext(
        "sampling.weights.normalization should be total, group or none."))
    }
  }

  # block.labels
  block.label <- character(0L)
  if (length(group.label) > 0L && length(level.label) == 0L) {
    block.label <- group.label
  } else if (length(level.label) > 0L && length(group.label) == 0L) {
    block.label <- level.label
  } else if (length(group.label) > 0L &&
    length(level.label) > 0L) {
    block.label <- paste(rep(group.label, each = length(level.label)),
      rep(level.label, times = length(group.label)),
      sep = "."
    )
  }


  lavData <- new("lavData",
    data.type = "full",
    ngroups = ngroups,
    group = group,
    nlevels = nlevels,
    cluster = cluster,
    group.label = group.label,
    level.label = level.label,
    block.label = block.label,
    std.ov = std.ov,
    nobs = nobs,
    norig = norig,
    ov.names = ov.names,
    ov.names.x = ov.names.x,
    ov.names.l = ov.names.l,
    # ov.types        = ov.types,
    # ov.idx          = ov.idx,
    ordered = as.character(ordered),
    weights = weights,
    sampling.weights = sampling.weights,
    ov = ov,
    case.idx = case.idx,
    missing = missing,
    X = X,
    eXo = eXo,
    Mp = Mp,
    Rp = Rp,
    Lp = Lp
  )
  lavData
}

# constrained optimization
# - references: * Nocedal & Wright (2006) Chapter 17
#               * Optimization with constraints by Madsen, Nielsen & Tingleff
#               * original papers: Powell, 1969 and Rockafeller, 1974
# - using 'nlminb' for the unconstrained subproblem
# - convergence scheme is based on the auglag function in the alabama package
nlminb.constr <- function(start, objective, gradient = NULL, hessian = NULL,
                          ..., scale = 1, control = list(),
                          lower = -Inf, upper = Inf,
                          ceq = NULL, ceq.jac = NULL,
                          cin = NULL, cin.jac = NULL,
                          control.outer = list()) {
  # we need a gradient
  stopifnot(!is.null(gradient))

  # if no 'ceq' or 'cin' function, we create a dummy one
  if (is.null(ceq)) {
    ceq <- function(x, ...) {
      return(numeric(0))
    }
  }
  if (is.null(cin)) {
    cin <- function(x, ...) {
      return(numeric(0))
    }
  }

  # if no user-supplied jacobian functions, create them
  if (is.null(ceq.jac)) {
    if (is.null(ceq)) {
      ceq.jac <- function(x, ...) {
        matrix(0, nrow = 0L, ncol = length(x))
      }
    } else {
      ceq.jac <- function(x, ...) {
        numDeriv::jacobian(func = ceq, x = x, ...)
      }
    }
  }
  if (is.null(cin.jac)) {
    if (is.null(cin)) {
      cin.jac <- function(x, ...) {
        matrix(0, nrow = 0L, ncol = length(x))
      }
    } else {
      cin.jac <- function(x, ...) {
        numDeriv::jacobian(func = cin, x = x, ...)
      }
    }
  }

  # how many ceq and cin constraints?
  nceq <- length(ceq(start))
  ncin <- length(cin(start))
  ncon <- nceq + ncin
  ceq.idx <- cin.idx <- integer(0)
  if (nceq > 0L) ceq.idx <- 1:nceq
  if (ncin > 0L) cin.idx <- nceq + 1:ncin
  cin.flag <- rep(FALSE, length(ncon))
  if (ncin > 0L) cin.flag[cin.idx] <- TRUE

  # control outer default values
  control.outer.default <- list(
    mu0 = 100,
    lambda0 = 10,
    tol = 1e-06, # changed this in 0.4-12
    itmax = 100L,
    verbose = FALSE
  )
  control.outer <- modifyList(control.outer.default, control.outer)


  # construct augmented lagrangian function
  auglag <- function(x, ...) {
    # apply constraints
    ceq0 <- ceq(x, ...)
    cin0 <- cin(x, ...)
    con0 <- c(ceq0, cin0)
    # 'release' inactive constraints
    if (ncin > 0L) {
      slack <- lambda / mu
      inactive.idx <- which(cin.flag & con0 > slack)
      con0[inactive.idx] <- slack[inactive.idx]
    }
    objective(x, ...) - sum(lambda * con0) + (mu / 2) * sum(con0 * con0)
  }

  fgrad <- function(x, ...) {
    # apply constraints
    ceq0 <- ceq(x, ...)
    cin0 <- cin(x, ...)
    con0 <- c(ceq0, cin0)
    # jacobian
    JAC <- rbind(ceq.jac(x, ...), cin.jac(x, ...))
    lambda.JAC <- lambda * JAC

    # handle inactive constraints
    if (ncin > 0L) {
      slack <- lambda / mu
      inactive.idx <- which(cin.flag & con0 > slack)
      if (length(inactive.idx) > 0L) {
        JAC <- JAC[-inactive.idx, , drop = FALSE]
        lambda.JAC <- lambda.JAC[-inactive.idx, , drop = FALSE]
        con0 <- con0[-inactive.idx]
      }
    }

    if (nrow(JAC) > 0L) {
      (gradient(x, ...) - colSums(lambda.JAC) +
        mu * as.numeric(t(JAC) %*% con0))
    } else {
      gradient(x, ...)
    }
  }


  # initialization
  ceq0 <- ceq(start, ...)
  cin0 <- cin(start, ...)
  con0 <- c(ceq0, cin0)
  lambda <- rep(control.outer$lambda0, length(con0))
  mu <- control.outer$mu0
  inactive.idx <- integer(0)
  if (ncin > 0L) {
    slack <- lambda / mu
    inactive.idx <- which(cin.flag & con0 > slack)
    con0[inactive.idx] <- slack[inactive.idx]
  }
  K <- max(abs(con0))
  if (control.outer$verbose) {
    cat("init cin0 values: ", cin0, "\n")
    cat("init ceq0 values: ", ceq0, "\n")
    cat("init slack values: ", lambda / mu, "\n")
    cat("init inactive idx: ", inactive.idx, "\n")
    cat("init con0 values: ", con0, "\n")
    cat("K = max con0: ", K, "\n")
  }

  r <- obj <- objective(start, ...)
  feval <- 0L
  geval <- 0L
  niter <- 0L
  ilack <- 0L
  Kprev <- K
  mu0 <- control.outer$mu0 / Kprev
  if (is.infinite(mu0)) mu0 <- 1.0
  mu <- mu0

  K <- Inf
  x.par <- start
  for (i in 1:control.outer$itmax) {
    x.old <- x.par
    r.old <- r
    ############################################################
    if (control.outer$verbose) {
      cat("\nStarting inner optimization [", i, "]:\n")
      cat("lambda: ", lambda, "\n")
      cat("mu: ", mu, "\n")
    }
    optim.out <- nlminb(
      start = x.par, objective = auglag,
      gradient = fgrad, control = control,
      lower = lower, upper = upper,
      scale = scale, ...
    )
    ############################################################
    x.par <- optim.out$par
    r <- optim.out$objective
    feval <- feval + optim.out$evaluations[1]
    geval <- geval + optim.out$evaluations[2]
    niter <- niter + optim.out$iterations

    # check constraints
    ceq0 <- ceq(x.par, ...)
    cin0 <- cin(x.par, ...)
    con0 <- c(ceq0, cin0)
    if (ncin > 0L) {
      slack <- lambda / mu
      inactive.idx <- which(cin.flag & con0 > slack)
      con0[inactive.idx] <- slack[inactive.idx]
    }
    K <- max(abs(con0))
    if (control.outer$verbose) {
      cat("cin0 values: ", cin0, "\n")
      cat("ceq0 values: ", ceq0, "\n")
      cat("active threshold: ", lambda / mu, "\n")
      cat("inactive idx: ", inactive.idx, "\n")
      cat("con0 values: ", con0, "\n")
      cat("K = max con0: ", K, " Kprev = ", Kprev, "\n")
    }

    # update K or mu (see Powell, 1969)
    if (K <= Kprev / 4) {
      lambda <- lambda - (mu * con0)
      Kprev <- K
    } else {
      mu <- 10 * mu
    }

    # check convergence
    pconv <- max(abs(x.par - x.old))
    if (pconv < control.outer$tol) {
      ilack <- ilack + 1L
    } else {
      ilack <- 0L
    }

    if ((is.finite(r) && is.finite(r.old) &&
      abs(r - r.old) < control.outer$tol && K < control.outer$tol) |
      ilack >= 3) {
      break
    }
  }

  # output
  a <- list()

  if (i == control.outer$itmax) {
    a$convergence <- 10L
    a$message <- "nlminb.constr ran out of iterations and did not converge"
  } else if (K > control.outer$tol) {
    a$convergence <- 11L
    a$message <- "Convergence due to lack of progress in parameter updates"
  } else {
    a$convergence <- 0L
    a$message <- "converged"
  }
  a$par <- optim.out$par
  a$outer.iterations <- i
  a$lambda <- lambda
  a$mu <- mu
  # a$value <- objective(a$start, ...)
  # a$cin <- cin(a$start, ...)
  # a$ceq <- ceq(a$start, ...)
  a$evaluations <- c(feval, geval)
  a$iterations <- niter
  # a$kkt1 <- max(abs(a$fgrad)) <= 0.01 * (1 + abs(a$value))
  # a$kkt2 <- any(eigen(a$hessian)$value * control.optim$objectivescale> 0)

  # jacobian of ceq and 'active' cin
  ceq0 <- ceq(a$par, ...)
  cin0 <- cin(a$par, ...)
  con0 <- c(ceq0, cin0)
  JAC <- rbind(ceq.jac(a$par, ...), cin.jac(a$par, ...))
  inactive.idx <- integer(0L)
  cin.idx <- which(cin.flag)
  # ceq.idx <- which(!cin.flag)
  if (ncin > 0L) {
    # FIXME: slack value not too strict??
    slack <- 1e-05
    # cat("DEBUG:\n"); print(con0)
    inactive.idx <- which(cin.flag & abs(con0) > slack)
    # if(length(inactive.idx) > 0L) {
    #    JAC        <-        JAC[-inactive.idx,,drop=FALSE]
    # }
  }
  attr(JAC, "inactive.idx") <- inactive.idx
  attr(JAC, "cin.idx") <- cin.idx
  attr(JAC, "ceq.idx") <- ceq.idx
  a$con.jac <- JAC

  a
}

lav_lavaan_step02_options <- function(slotOptions = NULL, # nolint
                                      slotData = NULL, # nolint
                                      flat.model = NULL,
                                      ordered = NULL,
                                      sample.cov = NULL,
                                      sample.mean = NULL,
                                      sample.th = NULL,
                                      sample.nobs = NULL,
                                      ov.names.l = NULL,
                                      sampling.weights = NULL,
                                      constraints = NULL,
                                      group = NULL,
                                      ov.names.x = NULL,
                                      ov.names.y = NULL,
                                      dotdotdot = NULL,
                                      cluster = NULL,
                                      data = NULL) {
  # # # # # # # # # # # #
  # #  2. lavoptions  # #
  # # # # # # # # # # # #

  # if slotOptions not NULL
  #   copy to lavoptions and modify categorical/clustered/multilevel
  #     inserting a "." in the first position
  #   if necessary, overwrite with values in dotdotdot and issue a warning
  #   check if all names in dotdotdot are possible options, if not *** error ***
  #   create complete option list (lav_options_default) and substitute values
  #     given in dotdotdot
  #   if data, slotData and sample.cov NULL: opt$bounds = FALSE
  #   if slotData$data.type != "full" or (slotData and data = NULL):
  #     opt$missing = "listwise"
  #   set categorical mode ON if
  #     - an operator "|" (threshold) was used
  #     - data not NULL and one or more elements in ordered parameter
  #     - sample.th provided
  #     - at least one of the non-exogenous observed variables is "ordered"
  #       (ordered factor in R)
  #   if opt$estimator == "catml": set categorical mode OFF
  #       TODO: estimator = "CATML" isn't mentioned in lavOptions / estimator
  #             help text !?
  #   if cluster not NULL, set opt$.clustered TRUE and  *** error *** if
  #     categorical mode is ON
  #   opt$.multilevel = (length(ov.names.l) > 0L &&
  #                      length(ov.names.l[[1]]) > 1L)
  #   if sampling.weights not NULL en categorical mode OFF and opt$estimator
  #     in ("default", "ML", "PML")
  #     set opt$estimator to "MLR"
  #   if constraints present and estimator == "ML", set opt$information to
  #     c("observed", "observed")
  #   if there is an operator "~1" in flat.model and sample.mean not NULL,
  #     set opt$meanstructure TRUE
  #   if there are no exogenous variables but conditional.x explicitly
  #     requested: ** warning **
  #   if there are no exogenous variables set opt$conditional.x FALSE
  #   if there are no exogenous variables and fixed.x not explicitly requested,
  #     set opt$fixed.x to FALSE
  #   if allow.empty.cell and estimator not Bayes, issue a warning

  if (!is.null(slotOptions)) {
    lavoptions <- slotOptions

    # backwards compatibility
    if (!is.null(lavoptions$categorical)) {
      lavoptions$.categorical <- lavoptions$categorical
      lavoptions$categorical <- NULL
    }
    if (!is.null(lavoptions$clustered)) {
      lavoptions$.clustered <- lavoptions$clustered
      lavoptions$clustered <- NULL
    }
    if (!is.null(lavoptions$multilevel)) {
      lavoptions$.multilevel <- lavoptions$multilevel
      lavoptions$multilevel <- NULL
    }

    # but what if other 'options' are given anyway (eg 'start = ')?
    # give a warning!
    if (length(dotdotdot) > 0L) {
      dot.names <- names(dotdotdot)
      op.idx <- which(dot.names %in% names(slotOptions))
      lav_msg_warn(gettext(
        "the following argument(s) override(s) the options in slotOptions:"),
        paste(dot.names[op.idx], collapse = " ")
      )
      lavoptions[dot.names[op.idx]] <- dotdotdot[op.idx]
    }
  } else {
    if (lav_verbose()) {
      cat("lavoptions         ...")
    }

    # load default options
    opt <- lav_options_default()

    # catch unknown options
    ok.names <- names(opt)
    dot.names <- names(dotdotdot)
    wrong.idx <- which(!dot.names %in% ok.names)
    if (length(wrong.idx) > 0L) {
      # stop or warning?? stop for now (there could be more)
      lav_msg_stop(ngettext(length(wrong.idx),
        "unknown argument:", "unknown arguments:"),
        lav_msg_view(dot.names[wrong.idx], "none", FALSE)
      )
    }

    # modifyList
    opt <- modifyList(opt, dotdotdot)

    # extract estimator
    if (is.list(opt$estimator)) {
      estimator <- opt$estimator$estimator
    } else {
      estimator <- opt$estimator
    }

    # no data?
    if (is.null(slotData) && is.null(data) && is.null(sample.cov)) {
      opt$bounds <- FALSE
    }

    # only sample moments?
    if (!is.null(slotData) && !slotData@data.type == "full") {
      opt$missing <- "listwise"
    } else if (is.null(slotData) && is.null(data)) {
      opt$missing <- "listwise"
    }

    # categorical mode?
    opt$.categorical <- FALSE
    if (any(flat.model$op == "|")) {
      opt$.categorical <- TRUE
    } else if (!is.null(data) && length(ordered) > 0L) {
      opt$.categorical <- TRUE
    } else if (!is.null(sample.th)) {
      opt$.categorical <- TRUE
    } else if (is.data.frame(data)) {
      # first check if we can find ov.names.y in Data
      tmp.ov.names.y <- unique(unlist(ov.names.y))
      # remove possible interaction terms involving an y term
      int.idx <- which(grepl(":", tmp.ov.names.y))
      if (length(int.idx) > 0L) {
        tmp.ov.names.y <- tmp.ov.names.y[-int.idx]
      }
      idx.missing <- which(!(tmp.ov.names.y %in% names(data)))
      if (length(idx.missing)) {
        lav_msg_stop(
          gettext("missing observed variables in dataset:"),
          paste(tmp.ov.names.y[idx.missing], collapse = " ")
        )
      }
      if (any(sapply(data[, tmp.ov.names.y], inherits, "ordered"))) {
        opt$.categorical <- TRUE
      }
    }
    if (tolower(estimator) == "catml") {
      opt$.categorical <- FALSE
    }

    # clustered?
    if (length(cluster) > 0L) {
      opt$.clustered <- TRUE
      if (opt$.categorical && toupper(estimator) != "PML") {
        lav_msg_stop(gettext("categorical + clustered is not supported yet."))
      }
    } else {
      opt$.clustered <- FALSE
    }

    # multilevel?
    if (length(ov.names.l) > 0L && length(ov.names.l[[1]]) > 1L) {
      opt$.multilevel <- TRUE
    } else {
      opt$.multilevel <- FALSE
    }

    # sampling weights? force MLR
    # HJ 18/10/23: Except for PML
    if (!is.null(sampling.weights) && !opt$.categorical &&
      toupper(estimator) %in% c("DEFAULT", "ML", "PML")) {
      if (opt$se != "none") {
        opt$se <- "robust.huber.white"
      }
      if (opt$se != "none") {
        opt$test <- "yuan.bentler.mplus"
      }
    }

    # constraints
    if (any(nchar(constraints) > 0L) && toupper(estimator) %in% c("ML")) {
      opt$information <- c("observed", "observed")
    }

    # meanstructure
    if (any(flat.model$op == "~1") || !is.null(sample.mean)) {
      opt$meanstructure <- TRUE
    }
    if (!is.null(group) && is.null(dotdotdot$meanstructure)) {
      opt$meanstructure <- TRUE
    }

    # conditional.x
    if ((is.list(ov.names.x) &&
      sum(sapply(ov.names.x, FUN = length)) == 0L) ||
      (is.character(ov.names.x) && length(ov.names.x) == 0L)) {
      # if explicitly set to TRUE, give warning
      if (is.logical(dotdotdot$conditional.x) && dotdotdot$conditional.x) {
        lav_msg_warn(
          gettext("no exogenous covariates; conditional.x will be set to FALSE"))
      }
      opt$conditional.x <- FALSE
    }

    # fixed.x
    if ((is.list(ov.names.x) &&
      sum(sapply(ov.names.x, FUN = length)) == 0L) ||
      (is.character(ov.names.x) && length(ov.names.x) == 0L)) {
      # if explicitly set to TRUE, give warning
      if (is.logical(dotdotdot$fixed.x) && dotdotdot$fixed.x) {
        # ok, we respect this: keep fixed.x = TRUE
      } else {
        opt$fixed.x <- FALSE
      }
    }

    # allow.empty.cell
    if (opt$allow.empty.cell && opt$do.fit && toupper(estimator) != "BAYES") {
      lav_msg_warn(
        gettext("allow.empty.cell is not intended to salvage estimation of this model, see ?lavOptions"))
    }

    # fill in remaining "default" values
    lavoptions <- lav_options_set(opt)

    # store check.sigma.pd in lavaan_cache_env
    assign("opt.check.sigma.pd", opt$check.sigma.pd, lavaan_cache_env)

    if (lav_verbose()) {
      cat(" done.\n")
    }
  }

  lavoptions
}

# model gradient

lav_model_gradient <- function(lavmodel = NULL,
                               GLIST = NULL,
                               lavsamplestats = NULL,
                               lavdata = NULL,
                               lavcache = NULL,
                               type = "free",
                               group.weight = TRUE,
                               Delta = NULL,
                               m.el.idx = NULL,
                               x.el.idx = NULL,
                               ceq.simple = FALSE) {
  nmat <- lavmodel@nmat
  estimator <- lavmodel@estimator
  representation <- lavmodel@representation
  meanstructure <- lavmodel@meanstructure
  categorical <- lavmodel@categorical
  group.w.free <- lavmodel@group.w.free
  fixed.x <- lavmodel@fixed.x
  conditional.x <- lavmodel@conditional.x
  num.idx <- lavmodel@num.idx
  th.idx <- lavmodel@th.idx
  nx.free <- lavmodel@nx.free
  estimator.args <- lavmodel@estimator.args

  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  if (estimator == "REML") lav_msg_warn(gettext(
    "analytical gradient not implement; use numerical approximation"))

  # group.weight
  # FIXME --> block.weight
  if (group.weight) {
    if (estimator %in% c("ML", "PML", "FML", "MML", "REML", "NTRLS", "catML")) {
      group.w <- (unlist(lavsamplestats@nobs) / lavsamplestats@ntotal)
    } else if (estimator == "DLS") {
      if (estimator.args$dls.FtimesNminus1) {
        group.w <- ((unlist(lavsamplestats@nobs) - 1) / lavsamplestats@ntotal)
      } else {
        group.w <- (unlist(lavsamplestats@nobs) / lavsamplestats@ntotal)
      }
    } else {
      # FIXME: double check!
      group.w <- ((unlist(lavsamplestats@nobs) - 1) / lavsamplestats@ntotal)
    }
  } else {
    group.w <- rep(1.0, lavmodel@nblocks)
  }

  # do we need WLS.est?
  if (estimator %in% c("WLS", "DWLS", "ULS", "GLS", "NTRLS", "DLS")) {
    # always compute WLS.est
    WLS.est <- lav_model_wls_est(lavmodel = lavmodel, GLIST = GLIST) # ,
    # cov.x = lavsamplestats@cov.x)
  }

  if (estimator %in% c("ML", "PML", "FML", "REML", "NTRLS", "catML")) {
    # compute moments for all groups
    # if(conditional.x) {
    #    Sigma.hat <- lav_model_cond2joint_sigma(lavmodel = lavmodel,
    #                     GLIST = GLIST,
    #                     extra = (estimator %in% c("ML", "REML","NTRLS")))
    # } else {
    Sigma.hat <- lav_model_sigma(
      lavmodel = lavmodel, GLIST = GLIST,
      extra = (estimator %in% c(
        "ML", "REML",
        "NTRLS", "catML"
      ))
    )
    # }

    if (meanstructure) {
      # if(conditional.x) {
      #    Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST = GLIST)
      # } else {
      Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST = GLIST)
      # }
    }

    if (categorical) {
      TH <- lav_model_th(lavmodel = lavmodel, GLIST = GLIST)
    }

    if (conditional.x) {
      PI <- lav_model_pi(lavmodel = lavmodel, GLIST = GLIST)
    } else if (estimator == "PML") {
      PI <- vector("list", length = lavmodel@nblocks)
    }

    if (group.w.free) {
      GW <- lav_model_gw(lavmodel = lavmodel, GLIST = GLIST)
    }
  } else if (estimator == "DLS" && estimator.args$dls.GammaNT == "model") {
    Sigma.hat <- lav_model_sigma(
      lavmodel = lavmodel, GLIST = GLIST,
      extra = FALSE
    )
    Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST = GLIST)
  } else if (estimator == "MML") {
    TH <- lav_model_th(lavmodel = lavmodel, GLIST = GLIST)
    THETA <- lav_model_theta(lavmodel = lavmodel, GLIST = GLIST)
    GW <- lav_model_gw(lavmodel = lavmodel, GLIST = GLIST)
  }

  # four approaches (FIXME!!!! merge this!)
  # - ML approach: using Omega (and Omega.mu)
  #    Omega = 'POST' = Sigma.inv %*% (S - Sigma) %*% t(Sigma.inv)
  #   (still 2x faster than Delta method)
  # - WLS/DWLS/GLS: using Delta + WLS.V; support for fixed.x, conditional.x
  # - (ML)/NTRLS: using Delta, no support for fixed.x, conditional.x
  # - PML/FML/MML: custom

  # composites?
  composites.flag <- lavmodel@composites

  # 1. ML approach
  if ((estimator == "ML" || estimator == "REML" || estimator == "catML") &&
    lavdata@nlevels == 1L && !composites.flag &&
    !lavmodel@conditional.x) {
	correlation <- lavmodel@correlation
    if (meanstructure) {
      Omega <- lav_model_omega(
        Sigma.hat = Sigma.hat, Mu.hat = Mu.hat,
        lavsamplestats = lavsamplestats,
        estimator = estimator,
        meanstructure = TRUE,
        conditional.x = conditional.x,
		correlation = correlation
      )
      Omega.mu <- attr(Omega, "mu")
    } else {
      Omega <- lav_model_omega(
        Sigma.hat = Sigma.hat, Mu.hat = NULL,
        lavsamplestats = lavsamplestats,
        estimator = estimator,
        meanstructure = FALSE,
        conditional.x = conditional.x,
		correlation = correlation
      )
      Omega.mu <- vector("list", length = lavmodel@nblocks)
    }

    # compute DX (for all elements in every model matrix)
    DX <- vector("list", length = length(GLIST))

    for (g in 1:lavmodel@nblocks) {
      # which mm belong to group g?
      mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
      mm.names <- names(GLIST[mm.in.group])

      if (representation == "LISREL") {
        DX.group <- lav_lisrel_df_dmlist(
          GLIST[mm.in.group],
          Omega[[g]],
          Omega.mu[[g]]
        )

        # FIXME!!!
        # add empty gamma
        if (lavmodel@conditional.x) {
          DX.group$gamma <- lavmodel@GLIST$gamma
        }

        # only save what we need
        DX[mm.in.group] <- DX.group[mm.names]
      } else if (representation == "RAM") {
        DX.group <- lav_ram_df(
          GLIST[mm.in.group],
          Omega[[g]],
          Omega.mu[[g]]
        )
        # only save what we need
        DX[mm.in.group] <- DX.group[mm.names]
      } else {
        lav_msg_stop(gettext(
          "only LISREL and RAM representation has been implemented for now"))
      }

      # weight by group
      if (lavmodel@nblocks > 1L) {
        for (mm in mm.in.group) {
          DX[[mm]] <- group.w[g] * DX[[mm]]
        }
      }
    }

    # extract free parameters

    if (type == "free") {
      if (lavmodel@ceq.simple.only) { # new in 0.6-11
        dx <- numeric(lavmodel@nx.unco)
        for (g in 1:lavmodel@nblocks) {
          mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
          for (mm in mm.in.group) {
            m.free.idx <- lavmodel@m.free.idx[[mm]]
            x.unco.idx <- lavmodel@x.unco.idx[[mm]]
            dx[x.unco.idx] <- DX[[mm]][m.free.idx]
          }
        }
        if (ceq.simple) {
          dx <- drop(crossprod(lavmodel@ceq.simple.K, dx))
        }
      } else {
        dx <- numeric(nx.free)
        for (g in 1:lavmodel@nblocks) {
          mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
          for (mm in mm.in.group) {
            m.free.idx <- lavmodel@m.free.idx[[mm]]
            x.free.idx <- lavmodel@x.free.idx[[mm]]
            dx[x.free.idx] <- DX[[mm]][m.free.idx]
          }
        }
      }
    } else {
      dx <- DX
      # handle equality constraints
      ### FIXME!!!! TODO!!!!
    }
  } else # ML

  # 2. using Delta - *LS family
  if (estimator %in% c("WLS", "DWLS", "ULS", "GLS", "NTGLS", "DLS")) {
    if (type != "free") {
      if (is.null(Delta)) {
        lav_msg_fixme("Delta should be given if type != free")
      }
      # stop("FIXME: WLS gradient with type != free needs fixing!")
    } else {
      Delta <- lav_model_delta(
        lavmodel = lavmodel, GLIST. = GLIST,
        ceq.simple = ceq.simple
      )
    }

    for (g in 1:lavmodel@nblocks) {
      # diff <- as.matrix(lavsamplestats@WLS.obs[[g]]  - WLS.est[[g]])
      # group.dx <- -1 * ( t(Delta[[g]]) %*% lavsamplestats@WLS.V[[g]] %*% diff)
      # 0.5-17: use crossprod twice; treat DWLS/ULS special
      if (estimator == "WLS" ||
        estimator == "GLS" ||
        estimator == "DLS" ||
        estimator == "NTRLS") {
        # full weight matrix
        diff <- lavsamplestats@WLS.obs[[g]] - WLS.est[[g]]

        # full weight matrix
        if (estimator == "GLS" || estimator == "WLS") {
          WLS.V <- lavsamplestats@WLS.V[[g]]
          group.dx <- -1 * crossprod(
            Delta[[g]],
            crossprod(WLS.V, diff)
          )
        } else if (estimator == "DLS") {
          if (estimator.args$dls.GammaNT == "sample") {
            WLS.V <- lavsamplestats@WLS.V[[g]] # for now
          } else {
            dls.a <- estimator.args$dls.a
            GammaNT <- lav_samplestats_Gamma_NT(
              COV            = Sigma.hat[[g]],
              MEAN           = Mu.hat[[g]],
              rescale        = FALSE,
              x.idx          = lavsamplestats@x.idx[[g]],
              fixed.x        = lavmodel@fixed.x,
              conditional.x  = lavmodel@conditional.x,
              meanstructure  = lavmodel@meanstructure,
              slopestructure = lavmodel@conditional.x
            )
            W.DLS <- (1 - dls.a) * lavsamplestats@NACOV[[g]] + dls.a * GammaNT
            WLS.V <- lav_matrix_symmetric_inverse(W.DLS)
          }
          group.dx <- -1 * crossprod(
            Delta[[g]],
            crossprod(WLS.V, diff)
          )
        } else if (estimator == "NTRLS") {
          stopifnot(!conditional.x)
          # WLS.V <- lav_samplestats_Gamma_inverse_NT(
          #         ICOV = attr(Sigma.hat[[g]],"inv")[,,drop=FALSE],
          #         COV            = Sigma.hat[[g]][,,drop=FALSE],
          #         MEAN           = Mu.hat[[g]],
          #         x.idx          = lavsamplestats@x.idx[[g]],
          #         fixed.x        = fixed.x,
          #         conditional.x  = conditional.x,
          #         meanstructure  = meanstructure,
          #         slopestructure = conditional.x)

          S <- lavsamplestats@cov[[g]]
          Sigma <- Sigma.hat[[g]]
          Sigma.inv <- attr(Sigma, "inv")
          nvar <- NROW(Sigma)

          if (meanstructure) {
            MEAN <- lavsamplestats@mean[[g]]
            Mu <- Mu.hat[[g]]
            POST.Sigma <- lav_matrix_duplication_pre(
              matrix(
                (Sigma.inv %*% (S - Sigma) %*% t(Sigma.inv)) %*%
                  (diag(nvar) + (S - Sigma) %*% Sigma.inv) +
                  (Sigma.inv %*% tcrossprod(MEAN - Mu) %*% Sigma.inv),
                ncol = 1
              )
            )
            POST.Mu <- as.numeric(2 * Sigma.inv %*% (MEAN - Mu))
            POST <- c(POST.Mu, POST.Sigma)
          } else {
            POST <- lav_matrix_duplication_pre(
              matrix((Sigma.inv %*% (S - Sigma) %*% t(Sigma.inv)) %*%
                (diag(nvar) + (S - Sigma) %*% Sigma.inv), ncol = 1)
            )
          }

          group.dx <- as.numeric(-1 * crossprod(Delta[[g]], POST))
        }
      } else if (estimator == "DWLS" || estimator == "ULS") {
        # diagonal weight matrix
        diff <- lavsamplestats@WLS.obs[[g]] - WLS.est[[g]]
        group.dx <- -1 * crossprod(
          Delta[[g]],
          lavsamplestats@WLS.VD[[g]] * diff
        )
      }

      group.dx <- group.w[g] * group.dx
      if (g == 1) {
        dx <- group.dx
      } else {
        dx <- dx + group.dx
      }
    } # g

    if (type == "free") {
      # nothing to do
    } else {
      # make a GLIST
      dx <- lav_model_x2glist(
        lavmodel = lavmodel, x = dx,
        type = "custom", setDelta = FALSE,
        m.el.idx = m.el.idx,
        x.el.idx = x.el.idx
      )
    }
  } # WLS

  # ML + conditional.x
  else if (estimator %in% c("ML", "catML") && lavmodel@conditional.x &&
    lavdata@nlevels == 1L) {
    if (type != "free") {
      if (is.null(Delta)) {
        lav_msg_fixme("Delta should be given if type != free")
      }
      # stop("FIXME: WLS gradient with type != free needs fixing!")
    } else {
      Delta <- lav_model_delta(
        lavmodel = lavmodel, GLIST. = GLIST,
        ceq.simple = ceq.simple
      )
    }

    for (g in 1:lavmodel@nblocks) {
      # augmented mean.x + cov.x matrix
      mean.x <- lavsamplestats@mean.x[[g]]
      cov.x <- lavsamplestats@cov.x[[g]]
      C3 <- rbind(
        c(1, mean.x),
        cbind(mean.x, cov.x + tcrossprod(mean.x))
      )

      Sigma <- Sigma.hat[[g]]
      Mu.g <- Mu.hat[[g]]
      PI.g <- PI[[g]]
      Sigma.inv <- attr(Sigma, "inv")
      nvar <- NROW(Sigma)
      S <- lavsamplestats@res.cov[[g]]

      # beta
      OBS <- t(cbind(
        lavsamplestats@res.int[[g]],
        lavsamplestats@res.slopes[[g]]
      ))
      EST <- t(cbind(Mu.g, PI.g))
      # obs.beta <- c(lavsamplestats@res.int[[g]],
      #              lav_matrix_vec(lavsamplestats@res.slopes[[g]]))
      # est.beta <- c(Mu.g,  lav_matrix_vec(PI.g))
      # beta.COV <- C3 %x% Sigma.inv

      # a <- t(obs.beta - est.beta)
      # b <- as.matrix(obs.beta - est.beta)
      # K <- lav_matrix_commutation(m = nvar, n = nvar)
      # AB <- (K %x% diag(NROW(C3)*NROW(C3))) %*%
      #          (diag(nvar) %x% lav_matrix_vec(C3) %x% diag(nvar))
      # K <- lav_matrix_commutation(m = nvar, n = NROW(C3))
      # AB <- ( diag(NROW(C3)) %x% K %x% diag(nvar) ) %*%
      #        (lav_matrix_vec(C3) %x% diag( nvar * nvar) )

      # POST.beta <- 2 *  beta.COV %*% (obs.beta - est.beta)
      d.BETA <- C3 %*% (OBS - EST) %*% Sigma.inv
      # NOTE: the vecr here, unlike lav_mvreg_dlogl_beta
      #       this is because DELTA has used vec(t(BETA)),
      #       instead of vec(BETA)
      # POST.beta <- 2 * lav_matrix_vecr(d.BETA)
      # NOT any longer, since 0.6-1!!!
      POST.beta <- 2 * lav_matrix_vec(d.BETA)

      # POST.sigma1 <- lav_matrix_duplication_pre(
      #        (Sigma.inv %x% Sigma.inv)  %*% t(AB)  %*% (t(a) %x% b) )

      # Sigma
      # POST.sigma2 <- lav_matrix_duplication_pre(
      #                 matrix( lav_matrix_vec(
      #          Sigma.inv %*% (S - Sigma) %*% t(Sigma.inv)), ncol = 1L))
      W.tilde <- S + t(OBS - EST) %*% C3 %*% (OBS - EST)
      d.SIGMA <- (Sigma.inv - Sigma.inv %*% W.tilde %*% Sigma.inv)
      d.vechSigma <- as.numeric(lav_matrix_duplication_pre(
        as.matrix(lav_matrix_vec(d.SIGMA))
      ))
      POST.sigma <- -1 * d.vechSigma

      # POST <- c(POST.beta, POST.sigma1 + POST.sigma2)
      POST <- c(POST.beta, POST.sigma)

      group.dx <- as.numeric(-1 * crossprod(Delta[[g]], POST))

      # because we still use obj/2, we need to divide by 2!
      group.dx <- group.dx / 2 # fixed in 0.6-1

      group.dx <- group.w[g] * group.dx
      if (g == 1) {
        dx <- group.dx
      } else {
        dx <- dx + group.dx
      }
    } # g

    if (type == "free") {
      # nothing to do
    } else {
      # make a GLIST
      dx <- lav_model_x2glist(
        lavmodel = lavmodel, x = dx,
        type = "custom", setDelta = FALSE,
        m.el.idx = m.el.idx,
        x.el.idx = x.el.idx
      )
    }
  } # ML + conditional.x

  else if (estimator == "ML" && lavdata@nlevels > 1L) {
    if (type != "free") {
      lav_msg_fixme("type != free in lav_model_gradient for
                    estimator ML for nlevels > 1")
    } else {
      Delta <- lav_model_delta(
        lavmodel = lavmodel, GLIST. = GLIST,
        ceq.simple = ceq.simple
      )
    }

    # for each upper-level group....
    for (g in 1:lavmodel@ngroups) {
      if (!lavsamplestats@missing.flag) { # complete data
        if (lavmodel@conditional.x) {
          DX <- lav_mvreg_cluster_dlogl_2l_samplestats(
            YLp = lavsamplestats@YLp[[g]],
            Lp = lavdata@Lp[[g]],
            Res.Sigma.W = Sigma.hat[[(g - 1) * 2 + 1]],
            Res.Int.W = Mu.hat[[(g - 1) * 2 + 1]],
            Res.Pi.W = PI[[(g - 1) * 2 + 1]],
            Res.Sigma.B = Sigma.hat[[(g - 1) * 2 + 2]],
            Res.Int.B = Mu.hat[[(g - 1) * 2 + 2]],
            Res.Pi.B = PI[[(g - 1) * 2 + 2]],
            Sinv.method = "eigen"
          )
        } else {
          DX <- lav_mvnorm_cluster_dlogl_2l_samplestats(
            YLp = lavsamplestats@YLp[[g]],
            Lp = lavdata@Lp[[g]],
            Mu.W = Mu.hat[[(g - 1) * 2 + 1]],
            Sigma.W = Sigma.hat[[(g - 1) * 2 + 1]],
            Mu.B = Mu.hat[[(g - 1) * 2 + 2]],
            Sigma.B = Sigma.hat[[(g - 1) * 2 + 2]],
            Sinv.method = "eigen"
          )
        }
      } else {
        # missing data
        if (lavmodel@conditional.x) {
          lav_msg_stop(gettext("gradient for twolevel + conditional.x + fiml
                  is not ready; use optim.gradient = \"numerical\""))
        } else {
          DX <- lav_mvnorm_cluster_missing_dlogl_2l_samplestats(
            Y1 = lavdata@X[[g]],
            Y2 = lavsamplestats@YLp[[g]][[2]]$Y2,
            Lp = lavdata@Lp[[g]],
            Mp = lavdata@Mp[[g]],
            Mu.W = Mu.hat[[(g - 1) * 2 + 1]],
            Sigma.W = Sigma.hat[[(g - 1) * 2 + 1]],
            Mu.B = Mu.hat[[(g - 1) * 2 + 2]],
            Sigma.B = Sigma.hat[[(g - 1) * 2 + 2]],
            Sinv.method = "eigen"
          )
        }
      }

      group.dx <- as.numeric(DX %*% Delta[[g]])

      # group weights (if any)
      group.dx <- group.w[g] * group.dx
      if (g == 1) {
        dx <- group.dx
      } else {
        dx <- dx + group.dx
      }
    } # g

    # divide by 2 * N
    dx <- dx / (2 * lavsamplestats@ntotal)

    # cat("dx1 (numerical) = \n"); print( zapsmall(dx1) )
    # cat("dx  (analytic)  = \n"); print( zapsmall(dx ) )
  } # ML + two-level

  else if (estimator == "PML" || estimator == "FML" ||
    estimator == "MML") {
    if (type != "free") {
      lav_msg_fixme("type != free in lav_model_gradient for estimator PML")
    } else {
      Delta <- lav_model_delta(
        lavmodel = lavmodel, GLIST. = GLIST,
        ceq.simple = ceq.simple
      )
    }

    for (g in 1:lavmodel@nblocks) {
      # print(GLIST)
      # print(lav_model_get_parameters(lavmodel = lavmodel, GLIST = GLIST))
      # print(Sigma.hat[[g]])
      # print(TH[[g]])
      # cat("*****\n")

      # compute partial derivative of logLik with respect to
      # thresholds/means, slopes, variances, correlations
      if (estimator == "PML") {
        if (lavdata@nlevels > 1L) {
          lav_msg_stop(gettext(
            "PL gradient + multilevel not implemented;
            try optim.gradient = \"numerical\""))
        } else if (conditional.x) {
          d1 <- lav_pml_dploglik_dimplied(
            Sigma.hat = Sigma.hat[[g]],
            Mu.hat = Mu.hat[[g]],
            TH = TH[[g]],
            th.idx = th.idx[[g]],
            num.idx = num.idx[[g]],
            X = lavdata@X[[g]],
            lavcache = lavcache[[g]],
            eXo = lavdata@eXo[[g]],
            wt = lavdata@weights[[g]],
            PI = PI[[g]],
            missing = lavdata@missing
          )
        } else {
          d1 <- lav_pml_dploglik_dimplied(
            Sigma.hat = Sigma.hat[[g]],
            Mu.hat = Mu.hat[[g]],
            TH = TH[[g]],
            th.idx = th.idx[[g]],
            num.idx = num.idx[[g]],
            X = lavdata@X[[g]],
            lavcache = lavcache[[g]],
            eXo = NULL,
            wt = lavdata@weights[[g]],
            PI = NULL,
            missing = lavdata@missing
          )
        } # not conditional.x

        # chain rule (fmin)
        group.dx <-
          as.numeric(t(d1) %*% Delta[[g]])
      } # PML

      else if (estimator == "FML") {
        d1 <- lav_pml_fml_dploglik_dimplied(
          Sigma.hat = Sigma.hat[[g]],
          TH = TH[[g]],
          th.idx = th.idx[[g]],
          num.idx = num.idx[[g]],
          X = lavdata@X[[g]],
          lavcache = lavcache[[g]]
        )

        # chain rule (fmin)
        group.dx <-
          as.numeric(t(d1) %*% Delta[[g]]) / lavsamplestats@nobs[[g]]
      } else if (estimator == "MML") {
        group.dx <-
          lav_model_gradient_mml(
            lavmodel = lavmodel,
            GLIST = GLIST,
            THETA = THETA[[g]],
            TH = TH[[g]],
            group = g,
            lavdata = lavdata,
            sample.mean = lavsamplestats@mean[[g]],
            sample.mean.x = lavsamplestats@mean.x[[g]],
            lavcache = lavcache
          )
      }

      # group weights (if any)
      group.dx <- group.w[g] * group.dx
      if (g == 1) {
        dx <- group.dx
      } else {
        dx <- dx + group.dx
      }
    } # g
  } else {
    lav_msg_stop(gettext(
      "no analytical gradient available for estimator"), estimator)
  }


  # group.w.free for ML
  if (lavmodel@group.w.free &&
    estimator %in% c("ML", "MML", "FML", "PML", "REML", "catML")) {
    # est.prop <- unlist( lav_model_gw(lavmodel = lavmodel, GLIST = GLIST) )
    # obs.prop <- unlist(lavsamplestats@group.w)
    # FIXME: G2 based -- ML and friends only!!
    # dx.GW <- - (obs.prop - est.prop)

    # poisson version
    est.freq <- exp(unlist(lav_model_gw(lavmodel = lavmodel, GLIST = GLIST)))
    obs.freq <- unlist(lavsamplestats@group.w) * lavsamplestats@ntotal
    dx.GW <- -(obs.freq - est.freq)
    # divide by N (to be consistent with the rest of lavaan)
    dx.GW <- dx.GW / lavsamplestats@ntotal

    # remove last element (fixed LAST group to zero)
    # dx.GW <- dx.GW[-length(dx.GW)]

    # fill in in dx
    gw.mat.idx <- which(names(lavmodel@GLIST) == "gw")
    gw.x.idx <- unlist(lavmodel@x.free.idx[gw.mat.idx])
    dx[gw.x.idx] <- dx.GW
  }

  # dx is 1xnpar matrix of LIST (type != "free")
  if (is.matrix(dx)) {
    dx <- as.numeric(dx)
  }

  dx
}

# for testing purposes only
lav_model_delta_numerical <- function(lavmodel = NULL, GLIST = NULL, g = 1L) {

  # state or final?
  if(is.null(GLIST)) GLIST <- lavmodel@GLIST

  compute.moments <- function(x) {
    GLIST <- lav_model_x2glist(lavmodel = lavmodel, x = x, type = "free")
    Sigma.hat <- lav_model_sigma(lavmodel = lavmodel, GLIST = GLIST)
    S.vec <- lav_matrix_vech(Sigma.hat[[g]])
    if(lavmodel@meanstructure) {
      Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST=GLIST)
      out <- c(Mu.hat[[g]], S.vec)
    } else {
      out <- S.vec
    }
    out
  }

  x <- lav_model_get_parameters(lavmodel = lavmodel,
                                GLIST = GLIST, type = "free")
  Delta <- lav_func_jacobian_complex(func = compute.moments, x = x)

  Delta
}


### FIXME: should we here also:
###        - weight for groups? (no, for now)
###        - handle equality constraints? (yes, for now)
lav_model_delta <- function(lavmodel = NULL, GLIST. = NULL,
                         m.el.idx. = NULL, x.el.idx. = NULL,
                         ceq.simple = FALSE,
                         force.conditional.x.false = FALSE) {
  representation <- lavmodel@representation
  categorical <- lavmodel@categorical
  correlation <- lavmodel@correlation
  conditional.x <- lavmodel@conditional.x
  group.w.free <- lavmodel@group.w.free
  nmat <- lavmodel@nmat
  nblocks <- lavmodel@nblocks
  nvar <- lavmodel@nvar
  num.idx <- lavmodel@num.idx
  th.idx <- lavmodel@th.idx
  nexo <- lavmodel@nexo
  parameterization <- lavmodel@parameterization

  # number of thresholds per group (if any)
  nth <- sapply(th.idx, function(x) sum(x > 0L))

  # state or final?
  if (is.null(GLIST.)) {
    GLIST <- lavmodel@GLIST
  } else {
    GLIST <- GLIST.
  }

  # type = "free" or something else?
  type <- "nonfree"
  m.el.idx <- m.el.idx.
  x.el.idx <- x.el.idx.
  if (is.null(m.el.idx) && is.null(x.el.idx)) {
    type <- "free"
  }

  # number of rows in DELTA.group
  pstar <- integer(nblocks)
  for (g in 1:nblocks) {
    pstar[g] <- as.integer(nvar[g] * (nvar[g] + 1) / 2)
    if (lavmodel@meanstructure) {
      pstar[g] <- nvar[g] + pstar[g] # first the means, then sigma
    }
    if (categorical) {
      pstar[g] <- pstar[g] - nvar[g] # remove variances
      pstar[g] <- pstar[g] - nvar[g] # remove means

      pstar[g] <- pstar[g] + nth[g] # add thresholds
      pstar[g] <- pstar[g] + length(num.idx[[g]]) # add num means
      pstar[g] <- pstar[g] + length(num.idx[[g]]) # add num vars
    } else if (correlation) {
      pstar[g] <- pstar[g] - nvar[g] # remove variances
    }
    if (conditional.x && nexo[g] > 0L) {
      pstar[g] <- pstar[g] + (nvar[g] * nexo[g]) # add slopes
    }
    if (group.w.free) {
      pstar[g] <- pstar[g] + 1L # add group weight
    }
  }


  # number of columns in DELTA + m.el.idx/x.el.idx
  if (type == "free") {
    if (lavmodel@ceq.simple.only) {
      NCOL <- lavmodel@nx.unco
    } else {
      NCOL <- lavmodel@nx.free
    }
    m.el.idx <- x.el.idx <- vector("list", length = length(GLIST))
    for (mm in 1:length(GLIST)) {
      m.el.idx[[mm]] <- lavmodel@m.free.idx[[mm]]
      if (lavmodel@ceq.simple.only) {
        x.el.idx[[mm]] <- lavmodel@x.unco.idx[[mm]]
      } else {
        x.el.idx[[mm]] <- lavmodel@x.free.idx[[mm]]
      }
      # handle symmetric matrices
      if (lavmodel@isSymmetric[mm]) {
        # since we use 'x.free.idx', only symmetric elements
        # are duplicated (not the equal ones, only in x.free.free)
        dix <- duplicated(x.el.idx[[mm]])
        if (any(dix)) {
          m.el.idx[[mm]] <- m.el.idx[[mm]][!dix]
          x.el.idx[[mm]] <- x.el.idx[[mm]][!dix]
        }
      }
    }
  } else {
    ## FIXME: this does *not* take into account symmetric
    ##        matrices; hence NCOL will be too large, and empty
    ##        columns will be added
    ##        this is ugly, but it doesn't hurt
    ## alternative could be:
    ## NCOL <- sum(unlist(lapply(x.el.idx, function(x) length(unique(x)))))
    # NCOL <- sum(unlist(lapply(m.el.idx, length)))
    NCOL <- sum(unlist(lapply(x.el.idx, function(x) length(unique(x)))))
    # sanity check
    # nx <- sum(unlist(lapply(x.el.idx, length)))
    # stopifnot(NCOL == nx)
  }


  # compute Delta
  Delta <- vector("list", length = nblocks)
  for (g in 1:nblocks) {
    Delta.group <- matrix(0, nrow = pstar[g], ncol = NCOL)

    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]

    # label rows of Delta.group --- FIXME!!!
    # if(categorical) {
    #    # 1. th (means interleaved?)
    #    # 2. pi
    #    # 3. var num + cor
    # } else {
    #    if(meanstructure) {
    #    }
    # }
    # if(group.w.free) {
    # }

    # if theta, do some preparation
    if (representation == "LISREL" && parameterization == "theta") {
      sigma.hat <- lav_lisrel_sigma(
        MLIST = GLIST[mm.in.group],
        delta = FALSE
      )
      dsigma <- diag(sigma.hat)
      # dcor/dcov for sigma
      R <- lav_deriv_cov2cor(sigma.hat, num.idx = lavmodel@num.idx[[g]])
      theta.var.idx <- lav_matrix_diagh_idx(nvar[g])
    }

    for (mm in mm.in.group) {
      mname <- names(lavmodel@GLIST)[mm]

      # skip empty ones
      if (!length(m.el.idx[[mm]])) next

      # get Delta columns for this model matrix
      if (representation == "LISREL") {
        # Sigma
        DELTA <- dxSigma <-
          lav_lisrel_dsigma_dx(
            MLIST = GLIST[mm.in.group],
            m = mname,
            idx = m.el.idx[[mm]],
            delta = parameterization == "delta"
          )
        if (categorical && parameterization == "theta") {
          DELTA <- R %*% DELTA
        }

        if (categorical) {
          # reorder: first variances (of numeric), then covariances
          cov.idx <- lav_matrix_vech_idx(nvar[g])
          covd.idx <- lav_matrix_vech_idx(nvar[g], diagonal = FALSE)

          var.idx <- which(is.na(match(
            cov.idx,
            covd.idx
          )))[num.idx[[g]]]
          cor.idx <- match(covd.idx, cov.idx)

          DELTA <- rbind(
            DELTA[var.idx, , drop = FALSE],
            DELTA[cor.idx, , drop = FALSE]
          )
        }

        # correlation structure?
        if (!categorical && correlation) {
          rm.idx <- lav_matrix_diagh_idx(nvar[g])
          DELTA <- DELTA[-rm.idx, , drop = FALSE]
        }

        if (!categorical) {
          if (conditional.x) {
            # means/intercepts
            DELTA.mu <- lav_lisrel_dmu_dx(
              MLIST = GLIST[mm.in.group],
              m = mname,
              idx = m.el.idx[[mm]]
            )

            # slopes
            if (lavmodel@nexo[g] > 0L) {
              DELTA.pi <- lav_lisrel_dpi_dx(
                 MLIST = GLIST[mm.in.group],
                m = mname,
                idx = m.el.idx[[mm]]
              )

              if (lavmodel@multilevel) {
                DELTA <- rbind(DELTA.mu, DELTA.pi, DELTA)
              } else {
                # ATTENTION: we need to change the order here
                # lav_mvreg_scores_* uses 'Beta' where the
                # the intercepts are just the first row
                # using the col-major approach, we need to
                # interweave the intercepts with the slopes!

                nEls <- NROW(DELTA.mu) + NROW(DELTA.pi)
                # = (nexo + 1 int) * nvar

                # intercepts on top
                tmp <- rbind(DELTA.mu, DELTA.pi)
                # change row index
                row.idx <- lav_matrix_vec(matrix(seq.int(nEls),
                  nrow = lavmodel@nexo[g] + 1L,
                  ncol = lavmodel@nvar[g], byrow = TRUE
                ))
                DELTA.beta <- tmp[row.idx, , drop = FALSE]
                DELTA <- rbind(DELTA.beta, DELTA)
              }
            } else {
              DELTA <- rbind(DELTA.mu, DELTA)
            }
          } else if (!conditional.x && lavmodel@meanstructure) {
            DELTA.mu <- lav_lisrel_dmu_dx(
               MLIST = GLIST[mm.in.group],
              m = mname,
              idx = m.el.idx[[mm]]
            )
            DELTA <- rbind(DELTA.mu, DELTA)
          }
        } else if (categorical) {
          DELTA.th <- lav_lisrel_dth_dx(
            MLIST = GLIST[mm.in.group],
            m = mname,
            idx = m.el.idx[[mm]],
            th.idx = th.idx[[g]],
            delta = TRUE
          )
          if (parameterization == "theta") {
            # dy/ddsigma = -0.5/(ddsigma*sqrt(ddsigma))
            dDelta.dx <-
              (dxSigma[theta.var.idx, , drop = FALSE] *
                -0.5 / (dsigma * sqrt(dsigma)))
            dth.dDelta <-
              lav_lisrel_dth_dx(
                MLIST = GLIST[mm.in.group],
                m = "delta",
                idx = 1:nvar[g],
                th.idx = th.idx[[g]]
              )
            # add dth.dDelta %*% dDelta.dx
            no.num.idx <- which(th.idx[[g]] > 0)
            DELTA.th[no.num.idx, ] <-
              DELTA.th[no.num.idx, , drop = FALSE] +
              (dth.dDelta %*% dDelta.dx)[no.num.idx, , drop = FALSE]
          }
          if (conditional.x && lavmodel@nexo[g] > 0L) {
            DELTA.pi <-
              lav_lisrel_dpi_dx(
                MLIST = GLIST[mm.in.group],
                m = mname,
                idx = m.el.idx[[mm]]
              )
            if (parameterization == "theta") {
              dpi.dDelta <-
                lav_lisrel_dpi_dx(
                  MLIST = GLIST[mm.in.group],
                  m = "delta",
                  idx = 1:nvar[g]
                )
              # add dpi.dDelta %*% dDelta.dx
              no.num.idx <-
                which(!seq.int(1L, nvar[g]) %in% num.idx[[g]])
              no.num.idx <- rep(seq.int(0, nexo[g] - 1) * nvar[g],
                each = length(no.num.idx)
              ) + no.num.idx
              DELTA.pi[no.num.idx, ] <-
                DELTA.pi[no.num.idx, , drop = FALSE] +
                (dpi.dDelta %*% dDelta.dx)[no.num.idx, , drop = FALSE]
            }
            DELTA <- rbind(DELTA.th, DELTA.pi, DELTA)
          } else {
            DELTA <- rbind(DELTA.th, DELTA)
          }
        }
        if (group.w.free) {
          DELTA.gw <- lav_lisrel_dgw_dx(
            MLIST = GLIST[mm.in.group],
            m = mname,
            idx = m.el.idx[[mm]]
          )
          DELTA <- rbind(DELTA.gw, DELTA)
        }
      } else if (representation == "RAM") {
        DELTA <- dxSigma <-
          lav_ram_dsigma(
            m = mname,
            idx = m.el.idx[[mm]],
            MLIST = GLIST[mm.in.group]
          )
        if (lavmodel@meanstructure) {
          DELTA.mu <- lav_ram_dmu(
            m = mname,
            idx = m.el.idx[[mm]],
            MLIST = GLIST[mm.in.group]
          )
          DELTA <- rbind(DELTA.mu, DELTA)
        }
      } else {
        lav_msg_stop(gettextf("representation %s not implemented yet",
                              representation))
      }
      Delta.group[, x.el.idx[[mm]]] <- DELTA
    } # mm

    # if type == "free" take care of equality constraints
    if (type == "free" && ceq.simple && lavmodel@ceq.simple.only) {
      Delta.group <- Delta.group %*% lavmodel@ceq.simple.K
    }

    Delta[[g]] <- Delta.group
  } # g

  # if multilevel, rbind levels within group
  if (lavmodel@multilevel) {
    DELTA <- vector("list", length = lavmodel@ngroups)
    for (g in 1:lavmodel@ngroups) {
      DELTA[[g]] <- rbind(
        Delta[[(g - 1) * 2 + 1]],
        Delta[[(g - 1) * 2 + 2]]
      )
    }
    Delta <- DELTA
  }

  Delta
}

lav_model_ddelta_dx <- function(lavmodel = NULL, GLIST = NULL, target = "lambda",
                           ceq.simple = FALSE) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  representation <- lavmodel@representation
  nmat <- lavmodel@nmat
  nblocks <- lavmodel@nblocks
  th.idx <- lavmodel@th.idx

  # number of columns in DELTA + m.el.idx/x.el.idx
  type <- "free"
  # if(type == "free") {
  if (lavmodel@ceq.simple.only) {
    NCOL <- lavmodel@nx.unco
  } else {
    NCOL <- lavmodel@nx.free
  }
  m.el.idx <- x.el.idx <- vector("list", length = length(GLIST))
  for (mm in 1:length(GLIST)) {
    m.el.idx[[mm]] <- lavmodel@m.free.idx[[mm]]
    if (lavmodel@ceq.simple.only) {
      x.el.idx[[mm]] <- lavmodel@x.unco.idx[[mm]]
    } else {
      x.el.idx[[mm]] <- lavmodel@x.free.idx[[mm]]
    }
    # handle symmetric matrices
    if (lavmodel@isSymmetric[mm]) {
      # since we use 'x.free.idx', only symmetric elements
      # are duplicated (not the equal ones, only in x.free.free)
      dix <- duplicated(x.el.idx[[mm]])
      if (any(dix)) {
        m.el.idx[[mm]] <- m.el.idx[[mm]][!dix]
        x.el.idx[[mm]] <- x.el.idx[[mm]][!dix]
      }
    }
  }
  # } else {
  #    NCOL <- sum(unlist(lapply(x.el.idx, function(x) length(unique(x)))))
  # }

  # compute Delta per group
  Delta <- vector("list", length = nblocks)
  for (g in 1:nblocks) {
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    Delta.group <- NULL
    for (mm in mm.in.group) {
      mname <- names(lavmodel@GLIST)[mm]

      # skip empty ones
      if (!length(m.el.idx[[mm]])) next

      # get Delta columns for this model matrix
      if (representation == "LISREL") {
        if (target == "lambda") {
         DELTA <- lav_lisrel_dlambda_dx(
            MLIST = GLIST[mm.in.group],
            m = mname,
            idx = m.el.idx[[mm]]
          )
        } else if (target == "th") {
          DELTA <- lav_lisrel_dth_dx(
             MLIST = GLIST[mm.in.group], m = mname, th.idx = th.idx[[g]],
            idx = m.el.idx[[mm]],
            delta = TRUE
          )
        } else if (target == "mu") {
          DELTA <- lav_lisrel_dmu_dx(
            MLIST = GLIST[mm.in.group],
            m = mname,
            idx = m.el.idx[[mm]]
          )
        } else if (target == "nu") {
          DELTA <- lav_lisrel_dnu_dx(
            MLIST = GLIST[mm.in.group],
            m = mname,
            idx = m.el.idx[[mm]]
          )
        } else if (target == "tau") {
          DELTA <- lav_lisrel_dtau_dx(
            MLIST = GLIST[mm.in.group],
            m = mname,
            idx = m.el.idx[[mm]]
          )
        } else if (target == "theta") {
          DELTA <- lav_lisrel_dtheta_dx(
            MLIST = GLIST[mm.in.group],
            m = mname,
            idx = m.el.idx[[mm]]
          )
        } else if (target == "gamma") {
          DELTA <- lav_lisrel_dgamma_dx(
            MLIST = GLIST[mm.in.group],
            m = mname,
            idx = m.el.idx[[mm]]
          )
        } else if (target == "beta") {
          DELTA <- lav_lisrel_dbeta_dx(
            MLIST = GLIST[mm.in.group],
            m = mname,
            idx = m.el.idx[[mm]]
          )
        } else if (target == "alpha") {
          DELTA <- lav_lisrel_dalpha_dx(
            MLIST = GLIST[mm.in.group],
            m = mname,
            idx = m.el.idx[[mm]]
          )
        } else if (target == "psi") {
          DELTA <- lav_lisrel_dpsi_dx(
            MLIST = GLIST[mm.in.group],
            m = mname,
            idx = m.el.idx[[mm]]
          )
        } else if (target == "sigma") {
          DELTA <- lav_lisrel_dsigma_dx(
            MLIST = GLIST[mm.in.group],
            m = mname,
            idx = m.el.idx[[mm]],
            delta = TRUE
          )
        } else {
          lav_msg_stop(gettextf("target %s not implemented yet", target))
        }

        # initialize?
        if (is.null(Delta.group)) {
          Delta.group <- matrix(0, nrow = nrow(DELTA), ncol = NCOL)
        }
        Delta.group[, x.el.idx[[mm]]] <- DELTA
      }
    } # mm

    if (type == "free" && ceq.simple && lavmodel@ceq.simple.only) {
      Delta.group <- Delta.group %*% lavmodel@ceq.simple.K
    }

    Delta[[g]] <- Delta.group
  } # g

  Delta
}

lav_model_omega <- function(Sigma.hat = NULL, Mu.hat = NULL,
                         lavsamplestats = NULL, estimator = "ML",
                         meanstructure = FALSE, conditional.x = FALSE,
						 correlation = FALSE) {
  # nblocks
  nblocks <- length(Sigma.hat)

  Omega <- vector("list", length = nblocks)
  Omega.mu <- vector("list", length = nblocks)

  for (g in 1:nblocks) {
    # ML
    if (estimator %in% c("ML", "REML", "catML")) {
      if (attr(Sigma.hat[[g]], "po") == FALSE) {
        # FIXME: WHAT IS THE BEST THING TO DO HERE??
        # CURRENTLY: stop
        lav_msg_warn(gettext(
          "lav_model_gradient: Sigma.hat is not positive definite\n"))
        Sigma.hat.inv <- MASS::ginv(Sigma.hat[[g]])
      } else {
        Sigma.hat.inv <- attr(Sigma.hat[[g]], "inv")
      }

      if (!lavsamplestats@missing.flag) { # complete data
        if (meanstructure) {
          if (conditional.x) {
            diff <- lavsamplestats@res.int[[g]] - Mu.hat[[g]]
            W.tilde <- lavsamplestats@res.cov[[g]] + tcrossprod(diff)
          } else {
            diff <- lavsamplestats@mean[[g]] - Mu.hat[[g]]
            W.tilde <- lavsamplestats@cov[[g]] + tcrossprod(diff)
          }
          # Browne 1995 eq 4.55
          Omega.mu[[g]] <- t(t(diff) %*% Sigma.hat.inv)
          Omega[[g]] <-
            (Sigma.hat.inv %*% (W.tilde - Sigma.hat[[g]]) %*%
              Sigma.hat.inv)
        } else {
          if (conditional.x) {
            W.tilde <- lavsamplestats@res.cov[[g]]
          } else {
            W.tilde <- lavsamplestats@cov[[g]]
          }
          Omega[[g]] <-
            (Sigma.hat.inv %*% (W.tilde - Sigma.hat[[g]]) %*%
              Sigma.hat.inv)
        }
      } else { # missing data
        M <- lavsamplestats@missing[[g]]

        nvar <- ncol(lavsamplestats@cov[[g]])
        OMEGA <- matrix(0, nvar, nvar)
        OMEGA.MU <- matrix(0, nvar, 1)

        for (p in 1:length(M)) {
          SX <- M[[p]][["SY"]]
          MX <- M[[p]][["MY"]]
          nobs <- M[[p]][["freq"]]
          var.idx <- M[[p]][["var.idx"]]

          Sigma.inv <- chol2inv(chol(Sigma.hat[[g]][var.idx, var.idx]))
          Mu <- Mu.hat[[g]][var.idx]
          W.tilde <- SX + tcrossprod(MX - Mu)

          OMEGA.MU[var.idx, 1] <-
            (OMEGA.MU[var.idx, 1] + nobs / lavsamplestats@ntotal *
              t(t(MX - Mu) %*% Sigma.inv))

          OMEGA[var.idx, var.idx] <-
            (OMEGA[var.idx, var.idx] + nobs / lavsamplestats@ntotal *
              (Sigma.inv %*%
                (W.tilde - Sigma.hat[[g]][var.idx, var.idx]) %*%
                Sigma.inv))
        }
        Omega.mu[[g]] <- OMEGA.MU
        Omega[[g]] <- OMEGA
      } # missing

      # GLS
    } else if (estimator == "GLS") {
      W.inv <- lavsamplestats@icov[[g]]
      W <- lavsamplestats@cov[[g]]
      Omega[[g]] <- (lavsamplestats@nobs[[g]] - 1) / lavsamplestats@nobs[[g]] *
        (W.inv %*% (W - Sigma.hat[[g]]) %*% W.inv)
      if (meanstructure) {
        diff <- as.matrix(lavsamplestats@mean[[g]] - Mu.hat[[g]])
        Omega.mu[[g]] <- t(t(diff) %*% W.inv)
      }
    }

    # new in 0.6-18
	if(correlation) {
	    diag(Omega[[g]]) <- 0
	}
  } # g

  if (meanstructure) attr(Omega, "mu") <- Omega.mu

  Omega
}

lav_model_gradient_DD <- function(lavmodel, GLIST = NULL, group = 1L) {
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  #### FIX th + mu!!!!!
  Delta.lambda <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "lambda")[[group]]
  Delta.tau <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "tau")[[group]]
  Delta.nu <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "nu")[[group]]
  Delta.theta <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "theta")[[group]]
  Delta.beta <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "beta")[[group]]
  Delta.psi <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "psi")[[group]]
  Delta.alpha <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "alpha")[[group]]
  Delta.gamma <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "gamma")[[group]]

  ov.y.dummy.ov.idx <- lavmodel@ov.y.dummy.ov.idx[[group]]
  ov.x.dummy.ov.idx <- lavmodel@ov.x.dummy.ov.idx[[group]]
  ov.y.dummy.lv.idx <- lavmodel@ov.y.dummy.lv.idx[[group]]
  ov.x.dummy.lv.idx <- lavmodel@ov.x.dummy.lv.idx[[group]]
  ov.dummy.idx <- c(ov.y.dummy.ov.idx, ov.x.dummy.ov.idx)
  lv.dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx)
  th.idx <- lavmodel@th.idx[[group]]
  num.idx <- lavmodel@num.idx[[group]]
  ord.idx <- unique(th.idx[th.idx > 0L])

  # fix Delta's...
  mm.in.group <- 1:lavmodel@nmat[group] + cumsum(c(0, lavmodel@nmat))[group]
  MLIST <- GLIST[mm.in.group]

  DD <- list()
  nvar <- lavmodel@nvar
  nfac <- ncol(MLIST$lambda) - length(lv.dummy.idx)

  # DD$theta
  theta.idx <- lav_matrix_diagh_idx(nvar)
  DD$theta <- Delta.theta[theta.idx, , drop = FALSE]
  if (length(ov.dummy.idx) > 0L) {
    psi.idx <- lav_matrix_diagh_idx(ncol(MLIST$psi))[lv.dummy.idx]
    DD$theta[ov.dummy.idx, ] <- Delta.psi[psi.idx, , drop = FALSE]
  }
  # num only? FIXME or just all of them?
  DD$theta <- DD$theta[num.idx, , drop = FALSE]

  # DD$nu
  DD$nu <- Delta.nu
  if (length(ov.dummy.idx) > 0L) {
    DD$nu[ov.dummy.idx, ] <- Delta.alpha[lv.dummy.idx, ]
  }
  DD$nu <- DD$nu[num.idx, , drop = FALSE] # needed?

  # DD$lambda
  nr <- nvar
  nc <- nfac
  lambda.idx <- nr * ((1:nc) - 1L) + rep(1:nvar, each = nc)
  DD$lambda <- Delta.lambda[lambda.idx, , drop = FALSE]
  if (length(ov.dummy.idx) > 0L) {
    nr <- nrow(MLIST$beta)
    nc <- nfac # only the first 1:nfac columns
    # beta.idx <- rep(nr*((1:nc) - 1L), each=length(lv.dummy.idx)) + rep(lv.dummy.idx, times=nc) ## FIXME
    beta.idx <- rep(nr * ((1:nc) - 1L), times = length(lv.dummy.idx)) + rep(lv.dummy.idx, each = nc)

    # l.idx <- inr*((1:nc) - 1L) + rep(ov.dummy.idx, each=nc) ## FIXME
    # l.idx <- rep(nr*((1:nc) - 1L), each=length(ov.dummy.idx)) + rep(ov.dummy.idx, times=nc)
    l.idx <- rep(nr * ((1:nc) - 1L), times = length(ov.dummy.idx)) + rep(ov.dummy.idx, each = nc)
    DD$lambda[match(l.idx, lambda.idx), ] <- Delta.beta[beta.idx, , drop = FALSE]
  }

  # DD$KAPPA
  DD$kappa <- Delta.gamma
  if (length(ov.dummy.idx) > 0L) {
    nr <- nrow(MLIST$gamma)
    nc <- ncol(MLIST$gamma)
    kappa.idx <- nr * ((1:nc) - 1L) + rep(lv.dummy.idx, each = nc)
    DD$kappa <- DD$kappa[kappa.idx, , drop = FALSE]
  }

  # DD$GAMMA
  if (!is.null(MLIST$gamma)) {
    nr <- nrow(MLIST$gamma)
    nc <- ncol(MLIST$gamma)
    lv.idx <- 1:nfac
    # MUST BE ROWWISE!
    gamma.idx <- rep(nr * ((1:nc) - 1L), times = length(lv.idx)) + rep(lv.idx, each = nc)
    DD$gamma <- Delta.gamma[gamma.idx, , drop = FALSE]
  }

  # DD$BETA
  if (!is.null(MLIST$beta)) {
    nr <- nc <- nrow(MLIST$beta)
    lv.idx <- 1:nfac
    # MUST BE ROWWISE!
    beta.idx <- rep(nr * ((1:nfac) - 1L), times = nfac) + rep(lv.idx, each = nfac)
    DD$beta <- Delta.beta[beta.idx, , drop = FALSE]
  }

  ## DD$psi
  DD$psi <- Delta.psi
  if (length(lv.dummy.idx) > 0L) {
    nr <- nc <- nrow(MLIST$psi)
    lv.idx <- 1:nfac
    # MUST BE ROWWISE!
    psi.idx <- rep(nr * ((1:nfac) - 1L), times = nfac) + rep(lv.idx, each = nfac)

    DD$psi <- DD$psi[psi.idx, , drop = FALSE]
  }

  ## DD$tau
  if (!is.null(MLIST$tau)) {
    DD$tau <- Delta.tau
  }

  DD
}

# This file will (eventually) contain functions that can be used to
# 'predict' the values of outcome variables (y), given the values of
# input variables (x).

# first version YR 2 Nov 2022

# method = "conditional.mean" is based on the following article:

# Mark de Rooij, Julian D. Karch, Marjolein Fokkema, Zsuzsa Bakk, Bunga Citra
# Pratiwi & Henk Kelderman (2022) SEM-Based Out-of-Sample Predictions,
# StructuralEquation Modeling: A Multidisciplinary Journal
# DOI:10.1080/10705511.2022.2061494

# YR 31 Jan 2023: we always 'force' meanstructure = TRUE (for now)

# main function
lavPredictY <- function(object,
                        newdata = NULL,
                        ynames = lav_object_vnames(object, "ov.y"),
                        xnames = lav_object_vnames(object, "ov.x"),
                        method = "conditional.mean",
                        label = TRUE,
                        assemble = TRUE,
                        force.zero.mean = FALSE,
                        lambda = 0) {
  stopifnot(inherits(object, "lavaan"))
  # check object
  object <- lav_object_check_version(object)

  lavmodel <- object@Model
  lavdata <- object@Data
  lavimplied <- object@implied

  # check meanstructure
  if (!lavmodel@meanstructure) {
    lavimplied$mean <- lapply(object@SampleStats@mean, as.matrix)
  }

  # need full data set
  if (is.null(newdata)) {
    # use internal copy:
    if (lavdata@data.type != "full") {
      lav_msg_stop(gettext(
        "sample statistics were used for fitting and newdata is empty"
      ))
    } else if (is.null(lavdata@X[[1]])) {
      lav_msg_stop(gettext("no local copy of data; FIXME!"))
    } else {
      data.obs <- lavdata@X
      ov.names <- lavdata@ov.names
    }
    # eXo <- lavdata@eXo
  } else {
    # newdata is given!

    # create lavData object
    OV <- lavdata@ov
    newData <- lav_lavdata(
      data = newdata,
      group = lavdata@group,
      ov.names = lavdata@ov.names,
      ov.names.x = lavdata@ov.names.x,
      ordered = OV$name[OV$type == "ordered"],
      lavoptions = list(
        std.ov = lavdata@std.ov,
        group.label = lavdata@group.label,
        missing = "ml.x", # always!
        warn = TRUE
      ),
      allow.single.case = TRUE
    )
    # if ordered, check if number of levels is still the same (new in 0.6-7)
    if (lavmodel@categorical) {
      orig.ordered.idx <- which(lavdata@ov$type == "ordered")
      orig.ordered.lev <- lavdata@ov$nlev[orig.ordered.idx]
      match.new.idx <- match(
        lavdata@ov$name[orig.ordered.idx],
        newData@ov$name
      )
      new.ordered.lev <- newData@ov$nlev[match.new.idx]
      if (any(orig.ordered.lev - new.ordered.lev != 0)) {
        lav_msg_stop(gettext(
          "mismatch number of categories for some ordered variables in
          newdata compared to original data."
        ))
      }
    }

    data.obs <- newData@X
    # eXo <- newData@eXo
    ov.names <- newData@ov.names
  } # newdata

  # check ynames
  if (length(ynames) == 0L) {
    lav_msg_stop(gettext(
      "please specify the y-variables in the ynames= argument"
    ))
  }

  if (anyDuplicated((ynames))) {
    lav_msg_stop(gettext(
      "ynames contains duplicate variable names"
    ))
  }

  if (!is.list(ynames)) {
    ynames <- rep(list(ynames), lavdata@ngroups)
  }

  # check xnames
  if (length(xnames) == 0L) {
    lav_msg_stop(gettext(
      "please specify the x-variables in the xnames= argument"
    ))
  }

  if (anyDuplicated((xnames))) {
    lav_msg_stop(gettext(
      "ynames contains duplicate variable names"
    ))
  }

  if (!is.list(xnames)) {
    xnames <- rep(list(xnames), lavdata@ngroups)
  }

  # create y.idx and x.idx
  y.idx <- x.idx <- vector("list", lavdata@ngroups)
  for (g in seq_len(lavdata@ngroups)) {
    # ynames in ov.names for this group?
    missing.idx <- which(!ynames[[g]] %in% ov.names[[g]])
    if (length(missing.idx) > 0L) {
      lav_msg_stop(
        gettext(
          "some variable names in ynames do not appear in the dataset:"
        ),
        lav_msg_view(ynames[[g]][missing.idx], "none")
      )
    } else {
      y.idx[[g]] <- match(ynames[[g]], ov.names[[g]])
    }

    # xnames in ov.names for this group?
    missing.idx <- which(!xnames[[g]] %in% ov.names[[g]])
    if (length(missing.idx) > 0L) {
      lav_msg_stop(
        gettext(
          "some variable names in xnames do not appear in the dataset:"
        ),
        lav_msg_view(xnames[[g]][missing.idx], "none")
      )
    } else {
      x.idx[[g]] <- match(xnames[[g]], ov.names[[g]])
    }
  }

  # prediction method
  method <- tolower(method)
  if (method == "conditional.mean") {
    out <- lav_predict_y_conditional_mean(
      lavobject = NULL,
      lavmodel = lavmodel, lavdata = lavdata,
      lavimplied = lavimplied,
      data.obs = data.obs, y.idx = y.idx, x.idx = x.idx,
      force.zero.mean = force.zero.mean,
      lambda = lambda
    )
  } else {
    lav_msg_stop(gettext("method must be \"conditional.mean\" (for now)."))
  }

  # label?
  if (label) {
    # column names
    for (g in seq_len(lavdata@ngroups)) {
      colnames(out[[g]]) <- ynames[[g]]
    }

    # group.labels
    if (lavdata@ngroups > 1L) {
      names(out) <- lavdata@group.label
    }
  }

  # lavaan.matrix
  out <- lapply(out, "class<-", c("lavaan.matrix", "matrix"))

  if (lavdata@ngroups == 1L) {
    res <- out[[1L]]
  } else {
    res <- out
  }

  # assemble multiple groups into a single data.frame?
  if (lavdata@ngroups > 1L && assemble) {
    if (!is.null(newdata)) {
      lavdata <- newData
    }
    DATA <- matrix(as.numeric(NA),
      nrow = sum(unlist(lavdata@norig)),
      ncol = ncol(out[[1L]])
    ) # assume == per g
    colnames(DATA) <- colnames(out[[1L]])
    for (g in seq_len(lavdata@ngroups)) {
      DATA[lavdata@case.idx[[g]], ] <- out[[g]]
    }
    DATA <- as.data.frame(DATA, stringsAsFactors = FALSE)

    if (!is.null(newdata)) {
      DATA[, lavdata@group] <- newdata[, lavdata@group]
    } else {
      # add group
      DATA[, lavdata@group] <- rep(as.character(NA), nrow(DATA))
      if (lavdata@missing == "listwise") {
        # we will loose the group label of omitted variables!
        DATA[unlist(lavdata@case.idx), lavdata@group] <-
          rep(lavdata@group.label, unlist(lavdata@nobs))
      } else {
        DATA[unlist(lavdata@case.idx), lavdata@group] <-
          rep(lavdata@group.label, unlist(lavdata@norig))
      }
    }

    res <- DATA
  }

  res
}


# method = "conditional.mean"
lav_predict_y_conditional_mean <- function(
    lavobject = NULL, # for convenience
    # object ingredients
    lavmodel = NULL,
    lavdata = NULL,
    lavimplied = NULL,
    # new data
    data.obs = NULL,
    # y and x
    y.idx = NULL,
    x.idx = NULL,
    # options
    force.zero.mean = FALSE,
    lambda = lambda,
    level = 1L) { # not used for now

  # full object?
  if (inherits(lavobject, "lavaan")) {
    lavmodel <- lavobject@Model
    lavdata <- lavobject@Data
    # lavsamplestats <- lavobject@SampleStats
    lavimplied <- lavobject@implied
  } else {
    stopifnot(
      !is.null(lavmodel), !is.null(lavdata),
      # !is.null(lavsamplestats),
      !is.null(lavimplied)
    )
  }

  # data.obs?
  if (is.null(data.obs)) {
    data.obs <- lavdata@X
  }

  # checks
  if (lavmodel@categorical) {
    lav_msg_stop(gettext("no support for categorical data (yet)."))
  }
  if (lavdata@nlevels > 1L) {
    lav_msg_stop(gettext("no support for multilevel data (yet)."))
  }

  # conditional.x?
  if (lavmodel@conditional.x) {
    SigmaHat <- lav_model_cond2joint_sigma(lavmodel)
    if (lavmodel@meanstructure) {
      MuHat <- lav_model_cond2joint_mu(lavmodel)
    }
  } else {
    SigmaHat <- lavimplied$cov
    MuHat <- lavimplied$mean
  }

  # output container
  YPRED <- vector("list", length = lavdata@ngroups)

  # run over all groups
  for (g in 1:lavdata@ngroups) {
    # multiple levels?
    if (lavdata@nlevels > 1L) {
      # TODO!
      lav_msg_stop(gettext("no support for multilevel data (yet)!"))
    } else {
      data.obs.g <- data.obs[[g]]

      # model-implied variance-covariance matrix for this group
      cov.g <- SigmaHat[[g]]

      # model-implied mean vector for this group
      if (force.zero.mean) {
        mean.g <- rep(0, ncol(data.obs.g))
      } else {
        mean.g <- as.numeric(MuHat[[g]])
      }

      # indices (in ov.names)
      y.idx.g <- y.idx[[g]]
      x.idx.g <- x.idx[[g]]

      # partition y/x
      Sxx <- cov.g[x.idx.g, x.idx.g, drop = FALSE]
      Sxy <- cov.g[x.idx.g, y.idx.g, drop = FALSE]

      # x-data only
      Xtest <- data.obs.g[, x.idx.g, drop = FALSE]

      # mx/my
      mx <- mean.g[x.idx.g]
      my <- mean.g[y.idx.g]

      # center using mx
      Xtest <- t(t(Xtest) - mx)

      # Apply regularization
      Sxx <- Sxx + lambda * diag(nrow(Sxx))

      # prediction rule
      tmp <- Xtest %*% solve(Sxx, Sxy)
      YPRED[[g]] <- t(t(tmp) + my)
    } # single level
  } # g

  YPRED
}


# Takes a sequence of lambdas and performs k-fold cross-validation to determine
# the best lambda
lavPredictY_cv <- function(
    object,
    data = NULL,
    xnames = lav_object_vnames(object, "ov.x"),
    ynames = lav_object_vnames(object, "ov.y"),
    n.folds = 10L,
    lambda.seq = seq(0, 1, 0.1)) {

  # object should be (or inherit from) a lavaan object
  stopifnot(inherits(object, "lavaan"))
  # check object
  object <- lav_object_check_version(object)

  # results container
  results <- matrix(as.numeric(NA),
    nrow = length(lambda.seq) * n.folds,
    ncol = 2L
  )
  colnames(results) <- c("mse", "lambda")

  # shuffle folds
  folds <- sample(rep(1:n.folds, length.out = nrow(data)))

  # extract Y-data
  Y <- as.matrix(data[, ynames, drop = FALSE])

  j <- 0L
  for (i in 1:n.folds) {
    indis <- which(folds == i)
    fold.fit <- try(update(object,
      data = data[-indis, , drop = FALSE],
      warn = FALSE
    ), silent = TRUE)
	if (inherits(fold.fit, "try-error")) {
	  lav_msg_warn(gettext("failed fit in fold %s", i))
	  next
	}
    for (l in lambda.seq) {
      j <- j + 1L
      yhat <- lavPredictY(
        fold.fit,
        newdata = data[indis, , drop = FALSE],
        xnames = xnames,
        ynames = ynames,
        lambda = l
      )
      y.error <- Y[indis, , drop = FALSE] - yhat
      mse <- mean(y.error * y.error)
      results[j, ] <- c(mse, l)
    }
  }

  # Group by lambda and determine average MSE per group
  avg <- aggregate(results[, "mse"],
    by = list(results[, "lambda"]),
    FUN = mean, na.rm = TRUE
  )
  avg <- avg[order(avg[, 2]), ]
  names(avg) <- c("lambda", "mse")
  lambda.min <- avg[1L, "lambda"]

  list(results = avg, lambda.min = lambda.min)
}

# lavPredict() contains a collection of `predict' methods
# the unifying theme is that they all rely on the (unknown, to be estimated)
# or (known, apriori specified) values for the latent variables
#
# lv: latent variables (aka `factor scores')
# ov: predict linear part of y_i
#
# - YR 11 June 2013: first version, in order to get factor scores for the
#                    categorical case
# - YR 12 Jan 2014: refactoring + lav_predict_fy (to be used by estimator MML)
#
# - YR 25 Mar 2025: transformed factor scores (correlation-preserving)

# overload standard R function `predict'
setMethod(
  "predict", "lavaan",
  function(object, newdata = NULL, ...) {
    dotdotdot <- list(...)
    if (length(dotdotdot) > 0L) {
      for (j in seq_along(dotdotdot)) {
        lav_msg_warn(gettextf(
          "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
          sQuote("predict"))
        )
      }
    }
    lavPredict(
      object = object, newdata = newdata, type = "lv", method = "EBM",
      fsm = FALSE, rel = FALSE, optim.method = "bfgs"
    )
  }
)

# efaList version
lav_efalist_predict <- function(object, ...) {
  # kill object$loadings if present
  object[["loadings"]] <- NULL

  if (length(object) == 1L) {
    # unlist
    object <- object[[1]]
  } else {
    # use the 'last' one per default
    object <- object[[length(object)]]
  }

  predict(object, ...)
}

# public function
lavPredict <- function(object, newdata = NULL, # keep order of predict(), 0.6-7
                       type = "lv", method = "EBM", transform = FALSE,
                       se = "none", acov = "none", label = TRUE, fsm = FALSE,
                       mdist = FALSE, rel = FALSE,
                       append.data = FALSE, assemble = FALSE, # or TRUE?
                       level = 1L, optim.method = "bfgs", ETA = NULL,
                       drop.list.single.group = TRUE) {
  # check object
  object <- lav_object_check_version(object)

  # catch efaList objects
  if (inherits(object, "efaList")) {
    # kill object$loadings if present
    object[["loadings"]] <- NULL
    if (length(object) == 1L) {
      # unlist
      object <- object[[1]]
    } else {
      # use the 'last' one per default
      object <- object[[length(object)]]
    }
  }

  stopifnot(inherits(object, "lavaan"))
  lavmodel <- object@Model
  lavdata <- object@Data
  lavsamplestats <- object@SampleStats
  lavh1 <- object@h1
  lavimplied <- object@implied
  lavpartable <- object@ParTable

  # warn if the model does not contain any 'regular' latent variables
  if (length(lav_object_vnames(lavpartable, "lv.regular")) == 0L) {
    lav_msg_warn(gettextf("fitted model does not contain regular
    (i.e., measured) latent variables; the matrix of factor scores may
    contain no columns"))
  }

  res <- lav_predict_internal(
    lavmodel = lavmodel, lavdata = lavdata,
    lavsamplestats = lavsamplestats, lavimplied = lavimplied, lavh1 = lavh1,
    lavpartable = lavpartable, newdata = newdata, type = type, method = method,
    transform = transform, se = se, acov = acov, label = label,
    fsm = fsm, rel = rel,
    mdist = mdist, append.data = append.data, assemble = assemble,
    level = level, optim.method = optim.method, ETA = ETA,
    drop.list.single.group = drop.list.single.group
  )

  res
}

# internal version, to be used if lavobject does not exist yet
lav_predict_internal <- function(lavmodel = NULL,
                                 lavdata = NULL,
                                 lavsamplestats = NULL,
                                 lavh1 = NULL,
                                 lavimplied = NULL,
                                 lavpartable = NULL,
                                 # standard options
                                 newdata = NULL, # keep order of predict(), 0.6-7
                                 type = "lv", method = "EBM", transform = FALSE,
                                 se = "none", acov = "none", label = TRUE,
                                 fsm = FALSE, rel = FALSE,
                                 mdist = FALSE,
                                 append.data = FALSE, assemble = FALSE, # or TRUE?
                                 level = 1L, optim.method = "bfgs", ETA = NULL,
                                 drop.list.single.group = TRUE) {
  # type
  type <- tolower(type)
  lavpta <- lav_partable_attributes(lavpartable)
  if (type %in% c("latent", "lv", "factor", "factor.score", "factorscore")) {
    type <- "lv"
  } else if (type %in% c("ov", "yhat")) {
    type <- "yhat"
  } else if (type %in% c("residuals", "resid", "error")) {
    type <- "resid"
  }

  # if resid, not for categorical
  if (type == "resid" && lavmodel@categorical) {
    lav_msg_stop(gettext("casewise residuals not available if data is categorical"))
  }

  # append.data? check level
  if (append.data && level > 1L) {
    lav_msg_warn(gettext("append.data not available if level > 1L"))
    append.data <- FALSE
  }

  # mdist? -> fsm = TRUE
  if (mdist) {
    fsm <- TRUE
  }

  # se?
  if (acov != "none") {
    se <- acov # ACOV implies SE
  }
  if (se != "none") {
    if (is.logical(se) && se) {
      se <- "standard"
      if (acov != "none") {
        acov <- se # reverse-imply upstream
      }
    }
    if (type != "lv") {
      lav_msg_stop(gettext("standard errors only available if type = \"lv\""))
    }
    if (lavmodel@categorical) {
      se <- acov <- "none"
      lav_msg_warn(gettext(
        "standard errors not available (yet) for non-normal data"))
    }
    # if(lavdata@missing %in% c("ml", "ml.x")) {
    #    se <- acov <- "none"
    #    warning("lavaan WARNING: standard errors not available (yet) for missing data + fiml")
    # }
  }

  # need full data set supplied
  if (is.null(newdata)) {
    # use internal copy:
    if (lavdata@data.type != "full") {
      lav_msg_stop(gettext(
        "sample statistics were used for fitting and newdata is empty"))
    } else if (is.null(lavdata@X[[1]])) {
      lav_msg_stop(gettext("no local copy of data; FIXME!"))
    } else {
      data.obs <- lavdata@X
      ov.names <- lavdata@ov.names
    }
    eXo <- lavdata@eXo
  } else {
    OV <- lavdata@ov
    newData <- lav_lavdata(
      data = newdata,
      group = lavdata@group,
      ov.names = lavdata@ov.names,
      ov.names.x = lavdata@ov.names.x,
      ordered = OV$name[OV$type == "ordered"],
      lavoptions = list(
        std.ov = lavdata@std.ov,
        group.label = lavdata@group.label,
        missing = lavdata@missing
      ), # was FALSE before?
      allow.single.case = TRUE
    )
    # if ordered, check if number of levels is till the same (new in 0.6-7)
    if (lavmodel@categorical) {
      orig.ordered.idx <- which(lavdata@ov$type == "ordered")
      orig.ordered.lev <- lavdata@ov$nlev[orig.ordered.idx]
      match.new.idx <- match(
        lavdata@ov$name[orig.ordered.idx],
        newData@ov$name
      )
      new.ordered.lev <- newData@ov$nlev[match.new.idx]
      if (any(orig.ordered.lev - new.ordered.lev != 0)) {
        lav_msg_stop(
          gettext("mismatch number of categories for some ordered variables
                  in newdata compared to original data.")
        )
      }
    }
    data.obs <- newData@X
    eXo <- newData@eXo
    ov.names <- newData@ov.names
  }

  if (type == "lv") {
    if (!is.null(ETA)) {
      lav_msg_warn(gettext("lvs will be predicted here;
                           supplying ETA has no effect"))
    }

    # post fit check (lv pd?)
    # ok <- lav_object_post_check(object)
    # if(!ok) {
    #    stop("lavaan ERROR: lavInspect(,\"post.check\") is not TRUE; factor scores can not be computed. See the WARNING message.")
    # }

    out <- lav_predict_eta(
      lavobject = NULL, lavmodel = lavmodel,
      lavdata = lavdata, lavsamplestats = lavsamplestats,
      lavimplied = lavimplied, se = se, acov = acov, level = level,
      data.obs = data.obs, eXo = eXo, method = method,
      fsm = fsm, rel = rel, transform = transform, optim.method = optim.method
    )

    # extract fsm here
    if (fsm) {
      FSM <- attr(out, "fsm")
    }

	# extract rel here
	if (rel) {
	  REL <- attr(out, "rel")
	}

    # extract se here
    if (se != "none") {
      SE <- attr(out, "se")
      if (acov != "none") {
        ACOV <- attr(out, "acov")
      }
    }

    # remove dummy lv? (removes attr!)
    out <- lapply(seq_len(lavdata@ngroups), function(g) {
      # determine block
      if (lavdata@nlevels == 1L) {
        b <- g
      } else {
        b <- (g - 1) * lavdata@nlevels + level
      }
      lv.idx <- c(
        lavmodel@ov.y.dummy.lv.idx[[b]],
        lavmodel@ov.x.dummy.lv.idx[[b]]
      )
      ret <- out[[g]]
      if (length(lv.idx) > 0L) {
        ret <- out[[g]][, -lv.idx, drop = FALSE]
      }
      ret
    })

    # we need to remove the dummy's before we transform
    # (update 0.6-20: no longer needed... as transform happens internally)
    if (fsm) {
      FSM <- lapply(seq_len(lavdata@ngroups), function(g) {
        # determine block
        if (lavdata@nlevels == 1L) {
          b <- g
        } else {
          b <- (g - 1) * lavdata@nlevels + level
        }
        lv.idx <- c(
          lavmodel@ov.y.dummy.lv.idx[[b]],
          lavmodel@ov.x.dummy.lv.idx[[b]]
        )
        # ov.idx <- lavmodel@ov.x.dummy.ov.idx[[b]]
        # or should we use pta$vidx$ov.ind?
        ov.ind <- lavpta$vidx$ov.ind[[b]]
        ret <- FSM[[g]]
        if (length(lv.idx) > 0L) {
          if (is.matrix(FSM[[g]])) {
            ret <- FSM[[g]][-lv.idx, ov.ind, drop = FALSE]
          } else if (is.list(FSM[[g]])) {
            FSM[[g]] <- lapply(FSM[[g]], function(x) {
              ret <- x[-lv.idx, ov.ind, drop = FALSE]
              ret
            })
          }
        }
        ret
      })
    }

#   # new in 0.6-16
#   # we assume the dummy lv's have already been removed
#     if (transform) {
#       # VETA <- lav_model_veta(lavmodel = lavmodel, remove.dummy.lv = TRUE)
#       EETA <- lav_model_eeta(
#         lavmodel = lavmodel,
#         lavsamplestats = lavsamplestats, remove.dummy.lv = TRUE
#       )
#       # compute transformation matrix
#       if (tolower(method) %in% c("ebm", "regression")) {
#         tmat <- lav_predict_tmat_green(lavmodel = lavmodel,
#                                        lavimplied = lavimplied)
#       } else {
#         tmat <- lav_predict_tmat_det(lavmodel = lavmodel,
#                                      lavimplied = lavimplied)
#       }
#
#       # update FSM
#       if (fsm) {
#         FSM <- lapply(seq_len(lavdata@ngroups), function(g) {
#           # determine block
#           if (lavdata@nlevels == 1L) {
#             b <- g
#           } else {
#             b <- (g - 1) * lavdata@nlevels + level
#           }
#           ret <- tmat[[b]] %*% FSM[[g]]
#           ret
#         })
#       }
#
#       out <- lapply(seq_len(lavdata@ngroups), function(g) {
#         # determine block
#         if (lavdata@nlevels == 1L) {
#           b <- g
#         } else {
#           b <- (g - 1) * lavdata@nlevels + level
#         }
#
#         FS.centered <- scale(out[[g]], center = TRUE, scale = FALSE)
#         #FS.cov <- crossprod(FS.centered) / nrow(FS.centered)
#         #FS.cov.inv <- try(solve(FS.cov), silent = TRUE)
#         #if (inherits(FS.cov.inv, "try-error")) {
#         #  lav_msg_warn(
#         #    gettext("could not invert (co)variance matrix of factor scores;
#         #            returning original factor scores."))
#         #  return(out[[g]])
#         #}
#         #fs.inv.sqrt <- lav_matrix_symmetric_sqrt(FS.cov.inv)
#         #veta.sqrt <- lav_matrix_symmetric_sqrt(VETA[[g]])
#         #tmp <- FS.centered %*% fs.inv.sqrt %*% veta.sqrt
#         tmp <- FS.centered %*% t(tmat[[b]])
#         ret <- t(t(tmp) + drop(EETA[[g]]))
#
#         ret
#       })
#     }

    # new in 0.6-17
    if (mdist) {
      VETA <- lav_model_veta(lavmodel = lavmodel, remove.dummy.lv = TRUE)
      EETA <- lav_model_eeta(
        lavmodel = lavmodel,
        lavsamplestats = lavsamplestats, remove.dummy.lv = TRUE
      )
      MDIST <- lapply(seq_len(lavdata@ngroups), function(g) {
        A <- FSM[[g]]
        Sigma <- lavimplied$cov[[g]]
        if (transform) {
          fs.cov <- VETA[[g]]
        } else {
          fs.cov <- A %*% Sigma %*% t(A)
        }
        fs.cov.inv <- solve(fs.cov)
        # Mahalobis distance
        fs.c <- t(t(out[[g]]) - EETA[[g]]) # center
        df.squared <- rowSums((fs.c %*% fs.cov.inv) * fs.c)
        ret <- df.squared # squared!
        ret
      })
    }

    # append original/new data? (also remove attr)
    if (append.data && level == 1L) {
      out <- lapply(seq_len(lavdata@ngroups), function(g) {
        ret <- cbind(out[[g]], data.obs[[g]])
        ret
      })
    }

    if (se != "none") {
      SE <- lapply(seq_len(lavdata@ngroups), function(g) {
        # determine block
        if (lavdata@nlevels == 1L) {
          b <- g
        } else {
          b <- (g - 1) * lavdata@nlevels + level
        }
        lv.idx <- c(
          lavmodel@ov.y.dummy.lv.idx[[b]],
          lavmodel@ov.x.dummy.lv.idx[[b]]
        )
        ret <- SE[[g]]
        if (length(lv.idx) > 0L) {
          ret <- SE[[g]][, -lv.idx, drop = FALSE]
        }
        ret
      })
      if (acov != "none") {
        ACOV <- lapply(seq_len(lavdata@ngroups), function(g) {
          # determine block
          if (lavdata@nlevels == 1L) {
            b <- g
          } else {
            b <- (g - 1) * lavdata@nlevels + level
          }
          lv.idx <- c(
            lavmodel@ov.y.dummy.lv.idx[[b]],
            lavmodel@ov.x.dummy.lv.idx[[b]]
          )
          ret <- ACOV[[g]]
          if (length(lv.idx) > 0L) {
            if (is.matrix(ACOV[[g]])) {
              ret <- ACOV[[g]][-lv.idx, -lv.idx, drop = FALSE]
            } else if (is.list(ACOV[[g]])) {
              ret <- lapply(ACOV[[g]], function(x) {
                ret <- x[-lv.idx, -lv.idx, drop = FALSE]
                ret
              })
            }
          }
          ret
        })
      } # acov
    } # se

    # label?
    if (label) {
      for (g in seq_len(lavdata@ngroups)) {
        if (lavdata@nlevels > 1L) {
          gg <- (g - 1) * lavdata@nlevels + level
        } else {
          gg <- g
        }

        if (append.data) {
          colnames(out[[g]]) <- c(
            lavpta$vnames$lv[[gg]],
            ov.names[[g]]
          ) # !not gg
        } else {
          colnames(out[[g]]) <- lavpta$vnames$lv[[gg]]
        }

        if (fsm) {
          if (is.null(FSM[[g]])) {
            # skip
          } else if (is.matrix(FSM[[g]])) {
            dimnames(FSM[[g]]) <- list(
              lavpta$vnames$lv[[gg]],
              # ov.names[[g]]) # !not gg
              lavpta$vnames$ov.ind[[gg]]
            )
          } else if (is.list(FSM[[g]])) {
            FSM[[g]] <- lapply(FSM[[g]], function(x) {
              dimnames(x) <- list(
                lavpta$vnames$lv[[gg]],
                # ov.names[[g]]) # !not gg
                lavpta$vnames$ov.ind[[gg]]
              )
              x
            })
          }
        }

        if (se != "none") {
          if (!is.null(SE[[g]])) {
            colnames(SE[[g]]) <- lavpta$vnames$lv[[gg]]
          }
        }

        if (rel) {
          if (!is.null(REL[[g]])) {
            names(REL[[g]]) <- lavpta$vnames$lv[[gg]]
          }
        }

        if (acov != "none") {
          if (is.null(ACOV[[g]])) {
            # skip
          } else if (is.matrix(ACOV[[g]])) {
            dimnames(ACOV[[g]]) <- list(
              lavpta$vnames$lv[[gg]],
              lavpta$vnames$lv[[gg]]
            )
          } else if (is.list(ACOV[[g]])) {
            ACOV[[g]] <- lapply(ACOV[[g]], function(x) {
              dimnames(x) <- list(
                lavpta$vnames$lv[[gg]],
                lavpta$vnames$lv[[gg]]
              )
              x
            })
          }
        }
      } # g

      # group.labels
      if (lavdata@ngroups > 1L) {
        names(out) <- lavdata@group.label
        if (se != "none") {
          names(SE) <- lavdata@group.label
        }
        if (acov != "none") {
          names(ACOV) <- lavdata@group.label
        }
      }
    } # label

    # yhat: estimated value for the observed indicators, given (estimated)
    # factor scores
    # resid: y - yhat
  } else if (type %in% c("yhat", "resid")) {
    resid.flag <- type == "resid"
    out <- lav_predict_yhat(
      lavobject = NULL, lavmodel = lavmodel,
      lavdata = lavdata, lavsamplestats = lavsamplestats,
      lavimplied = lavimplied,
      data.obs = data.obs, eXo = eXo,
      ETA = ETA, method = method, optim.method = optim.method,
      fsm = fsm,
      resid.flag = resid.flag
    )
    if (fsm) {
      FSM <- attr(out, "fsm")
    }

    # label?
    if (label) {
      for (g in seq_len(lavdata@ngroups)) {
        colnames(out[[g]]) <- lavpta$vnames$ov[[g]]
      }
    }

    # mdist
    if (mdist) {
      LAMBDA <- lav_model_lambda(
        lavmodel = lavmodel,
        remove.dummy.lv = FALSE
      )
      MDIST <- lapply(seq_len(lavdata@ngroups), function(g) {
        Sigma <- lavimplied$cov[[g]]
        LA <- LAMBDA[[g]]
        if (type == "resid") {
          ILA <- diag(ncol(Sigma)) - LA %*% FSM[[g]]
          Omega.e <- ILA %*% Sigma %*% t(ILA)
          eig <- eigen(Omega.e, symmetric = TRUE)
          A <- eig$vectors[, seq_len(nrow(LA) - ncol(LA)),
            drop = FALSE
          ]
        } else if (type == "yhat") {
          LAA <- LA %*% FSM[[g]]
          Omega.e <- LAA %*% Sigma %*% t(LAA)
          eig <- eigen(Omega.e, symmetric = TRUE)
          A <- eig$vectors[, seq_len(ncol(LA)), drop = FALSE]
        }
        outA <- apply(out[[g]], 1L, function(x) {
          colSums(A * x, na.rm = TRUE)
        })
        if (is.matrix(outA)) {
          outA <- t(outA)
        } else {
          outA <- as.matrix(outA)
        }
        # if(lavmodel@meanstructure) {
        #     est.mean <- drop(t(lavimplied$mean[[g]]) %*% A)
        #     if(type == "resid") {
        #         obs.mean <- drop(lavh1$implied$mean[[g]] %*% A)
        #         est.mean <- drop(t(lavimplied$mean[[g]]) %*% A)
        #         outA.mean <- obs.mean - est.mean
        #     } else if(type == "yhat") {
        #         outA.mean <- est.mean
        #     }
        # } else {
        #     outA.mean <- colMeans(outA)
        # }
        outA.cov <- t(A) %*% Omega.e %*% A
        outA.cov.inv <- solve(outA.cov)
        # Mahalobis distance
        # outA.c <- t( t(outA) - outA.mean ) # center
        outA.c <- outA
        df.squared <- rowSums((outA.c %*% outA.cov.inv) * outA.c)
        ret <- df.squared # squared!
        ret
      })
    }


    # density for each observed item, given (estimated) factor scores
  } else if (type == "fy") {
    out <- lav_predict_fy(
      lavobject = NULL, lavmodel = lavmodel,
      lavdata = lavdata, lavsamplestats = lavsamplestats,
      lavimplied = lavimplied,
      data.obs = data.obs, eXo = eXo,
      ETA = ETA, method = method, optim.method = optim.method
    )

    # label?
    if (label) {
      for (g in seq_len(lavdata@ngroups)) {
        colnames(out[[g]]) <- lavpta$vnames$ov[[g]]
      }
    }
  } else {
    lav_msg_stop(gettext("type must be one of: lv yhat fy"))
  }

  # lavaan.matrix
  out <- lapply(out, "class<-", c("lavaan.matrix", "matrix"))

  if (lavdata@ngroups == 1L && drop.list.single.group) {
    res <- out[[1L]]
  } else {
    res <- out
  }

  # assemble multiple groups into a single data.frame? (new in 0.6-4)
  if (lavdata@ngroups > 1L && assemble) {
    if (!is.null(newdata)) {
      lavdata <- newData
    }
    DATA <- matrix(as.numeric(NA),
      nrow = sum(unlist(lavdata@norig)),
      ncol = ncol(out[[1L]])
    ) # assume == per g
    colnames(DATA) <- colnames(out[[1L]])
    for (g in seq_len(lavdata@ngroups)) {
      DATA[lavdata@case.idx[[g]], ] <- out[[g]]
    }
    DATA <- as.data.frame(DATA, stringsAsFactors = FALSE)

    if (!is.null(newdata)) {
      DATA[, lavdata@group] <- newdata[, lavdata@group]
    } else {
      # add group
      DATA[, lavdata@group] <- rep(as.character(NA), nrow(DATA))
      if (lavdata@missing == "listwise") {
        # we will loose the group label of omitted variables!
        DATA[unlist(lavdata@case.idx), lavdata@group] <-
          rep(lavdata@group.label, unlist(lavdata@nobs))
      } else {
        DATA[unlist(lavdata@case.idx), lavdata@group] <-
          rep(lavdata@group.label, unlist(lavdata@norig))
      }
    }

    res <- DATA
  }

  if (fsm && type == "lv") {
    attr(res, "fsm") <- FSM
  }

  if (rel && type == "lv") {
    attr(res, "rel") <- REL
  }

  if (mdist) {
    attr(res, "mdist") <- MDIST
  }

  if (se != "none") {
    attr(res, "se") <- SE
    # return full sampling covariance matrix?
    if (acov == "standard") {
      attr(res, "acov") <- ACOV
    }
  }

  res
}

# internal function
lav_predict_eta <- function(lavobject = NULL, # for convenience
                            # sub objects
                            lavmodel = NULL, lavdata = NULL,
                            lavsamplestats = NULL,
                            lavimplied = NULL,
                            # new data
                            data.obs = NULL, eXo = NULL,
                            # options
                            method = "EBM",
                            fsm = FALSE,
							rel = FALSE,
                            transform = FALSE,
                            se = "none", acov = "none",
                            level = 1L,
                            optim.method = "bfgs") {
  # full object?
  if (inherits(lavobject, "lavaan")) {
    lavdata <- lavobject@Data
  } else {
    stopifnot(!is.null(lavdata))
  }

  # method
  method <- tolower(method)

  # alias
  if (method == "regression") {
    method <- "ebm"
  } else if (method == "bartlett" || method == "bartlet") {
    method <- "ml"
  }

  # normal case?
  if (all(lavdata@ov$type == "numeric")) {
    if (method == "ebm") {
      out <- lav_predict_eta_normal(
        lavobject = lavobject,
        lavmodel = lavmodel, lavdata = lavdata,
        lavimplied = lavimplied, se = se, acov = acov,
        level = level, lavsamplestats = lavsamplestats,
        data.obs = data.obs, eXo = eXo, fsm = fsm, rel = rel,
        transform = transform
      )
    } else if (method == "ml") {
      out <- lav_predict_eta_bartlett(
        lavobject = lavobject,
        lavmodel = lavmodel, lavdata = lavdata,
        lavimplied = lavimplied, se = se, acov = acov,
        level = level, lavsamplestats = lavsamplestats,
        data.obs = data.obs, eXo = eXo, fsm = fsm, rel = rel,
        transform = transform
      )
    } else {
      lav_msg_stop(gettextf("unkown method: %s.", method))
    }
  } else {
    if (method == "ebm") {
      out <- lav_predict_eta_ebm_ml(
        lavobject = lavobject,
        lavmodel = lavmodel, lavdata = lavdata,
        lavsamplestats = lavsamplestats, se = se, acov = acov,
        level = level, data.obs = data.obs, eXo = eXo,
        ML = FALSE, optim.method = optim.method
      )
    } else if (method == "ml") {
      out <- lav_predict_eta_ebm_ml(
        lavobject = lavobject,
        lavmodel = lavmodel, lavdata = lavdata,
        lavsamplestats = lavsamplestats, se = se, acov = acov,
        level = level, data.obs = data.obs, eXo = eXo,
        ML = TRUE, optim.method = optim.method
      )
    } else {
      lav_msg_stop(gettextf("unkown method: %s.", method))
    }
  }

  out
}


# factor scores - normal case
# NOTE: this is the classic 'regression' method; for the linear/continuous
#       case, this is equivalent to both EB and EBM
lav_predict_eta_normal <- function(lavobject = NULL, # for convenience
                                   # sub objects
                                   lavmodel = NULL, lavdata = NULL,
                                   lavsamplestats = NULL,
                                   lavimplied = NULL,
                                   # optional new data
                                   data.obs = NULL, eXo = NULL,
                                   se = "none", acov = "none", level = 1L,
                                   fsm = FALSE, rel = FALSE,
                                   transform = FALSE) {
  # full object?
  if (inherits(lavobject, "lavaan")) {
    lavmodel <- lavobject@Model
    lavdata <- lavobject@Data
    lavsamplestats <- lavobject@SampleStats
    lavimplied <- lavobject@implied
  } else {
    stopifnot(
      !is.null(lavmodel), !is.null(lavdata),
      !is.null(lavsamplestats), !is.null(lavimplied)
    )
  }

  if (is.null(data.obs)) {
    data.obs <- lavdata@X
    newdata.flag <- FALSE
  } else {
    newdata.flag <- TRUE
  }
  # eXo not needed

  # missings? and missing = "ml"?
  if (lavdata@missing %in% c("ml", "ml.x")) {
    if (newdata.flag) {
      MP <- vector("list", lavdata@ngroups)
      for (g in seq_len(lavdata@ngroups)) {
        MP[[g]] <- lav_data_missing_patterns(data.obs[[g]])
      }
    } else {
      MP <- lavdata@Mp
    }
  }

  LAMBDA <- lav_model_lambda(lavmodel = lavmodel, remove.dummy.lv = FALSE)
  Sigma.hat <- lavimplied$cov
  Sigma.inv <- lapply(Sigma.hat, MASS::ginv)
  VETA <- lav_model_veta(lavmodel = lavmodel)
  EETA <- lav_model_eeta(lavmodel = lavmodel, lavsamplestats = lavsamplestats)
  EY <- lav_model_ey(lavmodel = lavmodel, lavsamplestats = lavsamplestats)

  FS <- vector("list", length = lavdata@ngroups)
  if (fsm) {
    FSM <- vector("list", length = lavdata@ngroups)
  }
  if (rel) {
    REL <- vector("list", length = lavdata@ngroups)
  }
  if (transform) {
    TMAT <- lav_predict_tmat_green(lavmodel = lavmodel,
                                   lavimplied = lavimplied)
  }

  if (acov != "none") {
    se <- acov # ACOV implies SE
  }
  if (se != "none") {
    SE <- vector("list", length = lavdata@ngroups)
    # return full sampling covariance matrix?
    if (acov != "none") {
      ACOV <- vector("list", length = lavdata@ngroups)
    }
  }

  for (g in 1:lavdata@ngroups) {
    # determine block
    if (lavdata@nlevels == 1L) {
      b <- g
    } else {
      b <- (g - 1) * lavdata@nlevels + level
    }

    VETA.g <- VETA[[b]]
    EETA.g <- EETA[[b]]
    LAMBDA.g <- LAMBDA[[b]]
    EY.g <- EY[[b]]
    Sigma.inv.g <- Sigma.inv[[b]]

    if (lavdata@nlevels > 1L) {
      Lp <- lavdata@Lp[[g]]
      YLp <- lavsamplestats@YLp[[g]]

      # implied for this group
      group.idx <- (g - 1) * lavdata@nlevels + seq_len(lavdata@nlevels)
      implied.group <- lapply(lavimplied, function(x) x[group.idx])

      # random effects (=random intercepts or cluster means)
      out <- lav_mvnorm_cluster_implied22l(
        Lp = Lp,
        implied = implied.group
      )
      MB.j <- lav_mvnorm_cluster_em_estep_ranef(
        YLp = YLp, Lp = Lp,
        sigma.w = out$sigma.w, sigma.b = out$sigma.b,
        sigma.zz = out$sigma.zz, sigma.yz = out$sigma.yz,
        mu.z = out$mu.z, mu.w = out$mu.w, mu.b = out$mu.b,
        se = FALSE
      )

      ov.idx <- Lp$ov.idx

      if (level == 1L) {
        data.W <- data.obs[[g]][, ov.idx[[1]]]
        data.B <- MB.j[Lp$cluster.idx[[2]], , drop = FALSE]

        # center
        data.obs.g <- data.W - data.B
      } else if (level == 2L) {
        Data.B <- matrix(0,
          nrow = nrow(MB.j),
          ncol = ncol(data.obs[[g]])
        )
        Data.B[, ov.idx[[1]]] <- MB.j
        between.idx <- Lp$between.idx[[2 * g]]
        if (length(between.idx) > 0L) {
          Data.B[, between.idx] <- data.obs[[g]][
            !duplicated(Lp$cluster.idx[[2]]),
            between.idx
          ]
        }
        data.obs.g <- Data.B[, ov.idx[[2]]]
      } else {
        lav_msg_stop(gettext("only 2 levels are supported"))
      }
    } else {
      data.obs.g <- data.obs[[b]]
    }

    nfac <- ncol(VETA.g)
    if (nfac == 0L) {
      FS[[g]] <- matrix(0, lavdata@nobs[[g]], nfac)
      next
    }

    # center data
    Yc <- t(t(data.obs.g) - EY.g)

    # sampling weights? -- CHECKME: needed??
    if (!is.null(lavdata@weights[[g]]) && level == 1L) {
      # EY.g is already weighted
      # use sampling.weights.normalization == "group"
      WT <- lavdata@weights[[g]]
      WT2 <- WT / sum(WT) * lavdata@nobs[[g]]
      Yc <- Yc * sqrt(WT2)
    }

    # global factor score coefficient matrix 'C'
    FSC <- VETA.g %*% t(LAMBDA.g) %*% Sigma.inv.g

    # transform?
    if (transform) {
      FSC <- TMAT[[b]] %*% FSC
    }

    # store fsm?
    if (fsm) {
      FSM.g <- FSC
    }

	# reliability?
	if (rel) {
	  Var.f <- FSC %*% Sigma.hat[[g]] %*% t(FSC)  # or S?
	  Cov.f.eta <- FSC %*% LAMBDA.g %*% VETA.g
	  Var.eta <- VETA.g
	  # FS.determinacy <- diag( diag(1/sqrt(diag(Var.f))) %*%
	  #                         Cov.f.eta %*%
	  #                         diag(1/sqrt(diag(Var.eta)))
	  #                       )
	  FS.determinacy <- ( diag(Cov.f.eta) /
	                      (sqrt(diag(Var.f)) * sqrt(diag(Var.eta))) )
	  REL.g <- FS.determinacy*FS.determinacy
	}

    # compute factor scores
    if (lavdata@missing %in% c("ml", "ml.x")) {
      # missing patterns for this group
      Mp <- MP[[g]]

      # factor scores container
      FS.g <- matrix(as.numeric(NA), nrow(Yc), ncol = length(EETA.g))

      # if(fsm) {
      #    FSM.g <- vector("list", length = Mp$npatterns)
      # }

      if (se == "standard") {
        SE.g <- matrix(as.numeric(NA), nrow(Yc), ncol = length(EETA.g))
      }

      if (acov == "standard") {
        ACOV.g <- vector("list", length = Mp$npatterns)
      }

      # compute FSC per pattern
      for (p in seq_len(Mp$npatterns)) {
        var.idx <- Mp$pat[p, ] # observed
        na.idx <- which(!var.idx) # missing

        # extract observed data for these (centered) cases
        Oc <- Yc[Mp$case.idx[[p]], Mp$pat[p, ], drop = FALSE]

        # invert Sigma (Sigma_22, observed part only) for this pattern
        Sigma_22.inv <- try(lav_matrix_symmetric_inverse_update(
          S.inv =
            Sigma.inv.g, rm.idx = na.idx,
          logdet = FALSE
        ), silent = TRUE)
        if (inherits(Sigma_22.inv, "try-error")) {
          lav_msg_stop(gettext("Sigma_22.inv cannot be inverted"))
        }

        lambda <- LAMBDA.g[var.idx, , drop = FALSE]
        FSC <- VETA.g %*% t(lambda) %*% Sigma_22.inv

        # FSM?
        # if(fsm) {
        #    tmp <- matrix(as.numeric(NA), nrow = ncol(lambda),
        #                  ncol = ncol(Yc))
        #    tmp[,var.idx] <- FSC
        #    FSM.g[[p]] <- tmp
        # }

        # factor score for this pattern
        FS.g[Mp$case.idx[[p]], ] <- t(FSC %*% t(Oc) + EETA.g)

        # SE?
        if (se == "standard") {
          tmp <- (VETA.g - VETA.g %*% t(lambda) %*%
            Sigma_22.inv %*% lambda %*% VETA.g)
          tmp.d <- diag(tmp)
          tmp.d[tmp.d < 1e-05] <- as.numeric(NA)

          # all cases in this pattern get the same SEs
          SE.g[Mp$case.idx[[p]], ] <- matrix(sqrt(tmp.d),
            nrow = length(Mp$case.idx[[p]]),
            ncol = ncol(SE.g), byrow = TRUE
          )
        }

        # ACOV?
        if (acov == "standard") {
          ACOV.g[[p]] <- tmp # for this pattern
        }
      } # p
    } else {
      # compute factor scores
      FS.g <- t(FSC %*% t(Yc) + EETA.g)
    }

    # replace values in dummy lv's by their observed counterpart
    if (length(lavmodel@ov.y.dummy.lv.idx[[g]]) > 0L && level == 1L) {
      FS.g[, lavmodel@ov.y.dummy.lv.idx[[g]]] <-
        data.obs.g[, lavmodel@ov.y.dummy.ov.idx[[g]], drop = FALSE]
    }
    if (length(lavmodel@ov.x.dummy.lv.idx[[g]]) > 0L && level == 1L) {
      FS.g[, lavmodel@ov.x.dummy.lv.idx[[g]]] <-
        data.obs.g[, lavmodel@ov.x.dummy.ov.idx[[g]], drop = FALSE]
    }

    FS[[g]] <- FS.g

    # FSM
    if (fsm) {
      FSM[[g]] <- FSM.g
    }

	# REL
	if (rel) {
	  REL[[g]] <- REL.g
	}

    # standard error
    if (se == "standard" && !transform) { # for now
      if (lavdata@missing %in% c("ml", "ml.x")) {
        SE[[g]] <- SE.g
        if (acov == "standard") {
          ACOV[[g]] <- ACOV.g
        }
      } else { # complete data
        tmp <- (VETA.g - VETA.g %*% t(LAMBDA.g) %*%
          Sigma.inv.g %*% LAMBDA.g %*% VETA.g)
        tmp.d <- diag(tmp)
        tmp.d[tmp.d < 1e-05] <- as.numeric(NA)
        SE[[g]] <- matrix(sqrt(tmp.d), nrow = 1L)

        # return full sampling covariance matrix?
        if (acov == "standard") {
          ACOV[[g]] <- tmp
        }
      }
    } # se = "standard"
  } # g

  if (fsm) {
    attr(FS, "fsm") <- FSM
  }
  if (rel) {
    attr(FS, "rel") <- REL
  }
  if (se != "none") {
    attr(FS, "se") <- SE
    # return full sampling covariance matrix?
    if (acov == "standard") {
      attr(FS, "acov") <- ACOV
    }
  }

  FS
}

# factor scores - normal case - Bartlett method
# NOTES: 1) this is the classic 'Bartlett' method; for the linear/continuous
#           case, this is equivalent to 'ML'
#        2) the usual formula is:
#               FSC = solve(lambda' theta.inv lambda) (lambda' theta.inv)
#           BUT to deal with singular THETA (with zeroes on the diagonal),
#           we use the 'GLS' version instead:
#               FSC = solve(lambda' sigma.inv lambda) (lambda' sigma.inv)
#           Reference: Bentler & Yuan (1997) 'Optimal Conditionally Unbiased
#                      Equivariant Factor Score Estimators'
#                      in Berkane (Ed) 'Latent variable modeling with
#                      applications to causality' (Springer-Verlag)
#        3) instead of solve(), we use MASS::ginv, for special settings where
#           -by construction- (lambda' sigma.inv lambda) is singular
#           note: this will destroy the conditionally unbiased property
#                 of Bartlett scores!!
lav_predict_eta_bartlett <- function(lavobject = NULL, # for convenience
                                     # sub objects
                                     lavmodel = NULL, lavdata = NULL,
                                     lavsamplestats = NULL,
                                     lavimplied = NULL,
                                     # optional new data
                                     data.obs = NULL, eXo = NULL,
                                     se = "none", acov = "none", level = 1L,
                                     fsm = FALSE, rel = FALSE,
                                     transform = FALSE) {
  # full object?
  if (inherits(lavobject, "lavaan")) {
    lavmodel <- lavobject@Model
    lavdata <- lavobject@Data
    lavsamplestats <- lavobject@SampleStats
    lavimplied <- lavobject@implied
  } else {
    stopifnot(
      !is.null(lavmodel), !is.null(lavdata),
      !is.null(lavsamplestats), !is.null(lavimplied)
    )
  }

  if (is.null(data.obs)) {
    data.obs <- lavdata@X
    newdata.flag <- FALSE
  } else {
    newdata.flag <- TRUE
  }
  # eXo not needed

  # missings? and missing = "ml"?
  if (lavdata@missing %in% c("ml", "ml.x")) {
    if (newdata.flag) {
      MP <- vector("list", lavdata@ngroups)
      for (g in seq_len(lavdata@ngroups)) {
        MP[[g]] <- lav_data_missing_patterns(data.obs[[g]])
      }
    } else {
      MP <- lavdata@Mp
    }
  }

  LAMBDA <- lav_model_lambda(lavmodel = lavmodel, remove.dummy.lv = FALSE)
  Sigma.hat <- lavimplied$cov
  Sigma.inv <- lapply(lavimplied$cov, MASS::ginv)
  VETA <- lav_model_veta(lavmodel = lavmodel) # for se only
  EETA <- lav_model_eeta(lavmodel = lavmodel, lavsamplestats = lavsamplestats)
  EY <- lav_model_ey(lavmodel = lavmodel, lavsamplestats = lavsamplestats)

  FS <- vector("list", length = lavdata@ngroups)
  if (fsm) {
    FSM <- vector("list", length = lavdata@ngroups)
  }
  if (rel) {
    REL <- vector("list", length = lavdata@ngroups)
  }
  if (transform) {
    TMAT <- lav_predict_tmat_det(lavmodel = lavmodel,
                                 lavimplied = lavimplied)
  }

  if (acov != "none") se <- acov # ACOV implies SE
  if (se != "none") {
    SE <- vector("list", length = lavdata@ngroups)
    # return full sampling covariance matrix?
    if (acov != "none") {
      ACOV <- vector("list", length = lavdata@ngroups)
    }
  }

  for (g in 1:lavdata@ngroups) {
    # determine block
    if (lavdata@nlevels == 1L) {
      b <- g
    } else {
      b <- (g - 1) * lavdata@nlevels + level
    }

    VETA.g <- VETA[[b]]
    EETA.g <- EETA[[b]]
    LAMBDA.g <- LAMBDA[[b]]
    EY.g <- EY[[b]]
    Sigma.inv.g <- Sigma.inv[[b]]

    if (lavdata@nlevels > 1L) {
      Lp <- lavdata@Lp[[g]]
      YLp <- lavsamplestats@YLp[[g]]

      # implied for this group
      group.idx <- (g - 1) * lavdata@nlevels + seq_len(lavdata@nlevels)
      implied.group <- lapply(lavimplied, function(x) x[group.idx])

      # random effects (=random intercepts or cluster means)
      # NOTE: is the 'ML' way not simply using the observed cluster
      #       means?
      out <- lav_mvnorm_cluster_implied22l(
        Lp = Lp,
        implied = implied.group
      )
      MB.j <- lav_mvnorm_cluster_em_estep_ranef(
        YLp = YLp, Lp = Lp,
        sigma.w = out$sigma.w, sigma.b = out$sigma.b,
        sigma.zz = out$sigma.zz, sigma.yz = out$sigma.yz,
        mu.z = out$mu.z, mu.w = out$mu.w, mu.b = out$mu.b,
        se = FALSE
      )

      ov.idx <- Lp$ov.idx

      if (level == 1L) {
        data.W <- data.obs[[g]][, ov.idx[[1]]]
        data.B <- MB.j[Lp$cluster.idx[[2]], , drop = FALSE]

        # center
        data.obs.g <- data.W - data.B
      } else if (level == 2L) {
        Data.B <- matrix(0,
          nrow = nrow(MB.j),
          ncol = ncol(data.obs[[g]])
        )
        Data.B[, ov.idx[[1]]] <- MB.j
        between.idx <- Lp$between.idx[[2 * g]]
        if (length(between.idx) > 0L) {
          Data.B[, between.idx] <- data.obs[[g]][
            !duplicated(Lp$cluster.idx[[2]]),
            between.idx
          ]
        }
        data.obs.g <- Data.B[, ov.idx[[2]]]
      } else {
        lav_msg_stop(gettext("only 2 levels are supported"))
      }
    } else {
      data.obs.g <- data.obs[[b]]
    }

    nfac <- ncol(VETA.g)
    if (nfac == 0L) {
      FS[[g]] <- matrix(0, lavdata@nobs[[g]], nfac)
      next
    }

    # center data
    Yc <- t(t(data.obs.g) - EY.g)

    # sampling weights? CHECKME: needed??
    if (!is.null(lavdata@weights[[g]]) && level == 1L) {
      # EY.g is already weighted
      # use sampling.weights.normalization == "group"
      WT <- lavdata@weights[[g]]
      WT2 <- WT / sum(WT) * lavdata@nobs[[g]]
      Yc <- Yc * sqrt(WT2)
    }

    # global factor score coefficient matrix 'C'
    FSC <- (MASS::ginv(t(LAMBDA.g) %*% Sigma.inv.g %*% LAMBDA.g)
    %*% t(LAMBDA.g) %*% Sigma.inv.g)

    # transform?
    if (transform) {
      FSC <- TMAT[[b]] %*% FSC
    }

    # store fsm?
    if (fsm) {
      # store fsm?
      FSM.g <- FSC
    }

	# reliability?
	if (rel) {
      Var.f <- FSC %*% Sigma.hat[[g]] %*% t(FSC)  # or S?
      Cov.f.eta <- FSC %*% LAMBDA.g %*% VETA.g
      Var.eta <- VETA.g
      # FS.determinacy <- diag( diag(1/sqrt(diag(Var.f))) %*%
      #                         Cov.f.eta %*%
      #                         diag(1/sqrt(diag(Var.eta)))
      #                       )
      FS.determinacy <- ( diag(Cov.f.eta) /
                          (sqrt(diag(Var.f)) * sqrt(diag(Var.eta))) )
      REL.g <- FS.determinacy*FS.determinacy
	}

    # compute factor scores
    if (lavdata@missing %in% c("ml", "ml.x")) {
      # missing patterns for this group
      Mp <- MP[[g]]

      # factor scores container
      FS.g <- matrix(as.numeric(NA), nrow(Yc), ncol = length(EETA.g))

      # if(fsm) {
      #    FSM.g <- vector("list", length = Mp$npatterns)
      # }

      if (se == "standard") {
        SE.g <- matrix(as.numeric(NA), nrow(Yc), ncol = length(EETA.g))
      }

      if (acov == "standard") {
        ACOV.g <- vector("list", length = Mp$npatterns)
      }

      # compute FSC per pattern
      for (p in seq_len(Mp$npatterns)) {
        var.idx <- Mp$pat[p, ] # observed
        na.idx <- which(!var.idx) # missing

        # extract observed data for these (centered) cases
        Oc <- Yc[Mp$case.idx[[p]], Mp$pat[p, ], drop = FALSE]

        # invert Sigma (Sigma_22, observed part only) for this pattern
        Sigma_22.inv <- try(lav_matrix_symmetric_inverse_update(
          S.inv =
            Sigma.inv.g, rm.idx = na.idx,
          logdet = FALSE
        ), silent = TRUE)
        if (inherits(Sigma_22.inv, "try-error")) {
          lav_msg_stop(gettext("Sigma_22.inv cannot be inverted"))
        }

        lambda <- LAMBDA.g[var.idx, , drop = FALSE]
        FSC <- (MASS::ginv(t(lambda) %*% Sigma_22.inv %*% lambda)
        %*% t(lambda) %*% Sigma_22.inv)

        # if FSC contains rows that are all-zero, replace by NA
        #
        # this happens eg if all the indicators of a single factor
        # are missing; then this column in lambda only contains zeroes
        # and therefore the corresponding row in FSC contains only
        # zeroes, leading to factor score 0
        #
        # showing 'NA' is better than getting 0
        #
        # (Note that this is not needed for the 'regression' method,
        #  only for Bartlett)
        #
        zero.idx <- which(apply(FSC, 1L, function(x) all(x == 0)))
        if (length(zero.idx) > 0L) {
          FSC[zero.idx, ] <- NA
        }

        # FSM?
        # if(fsm) {
        #    tmp <- matrix(as.numeric(NA), nrow = ncol(lambda),
        #                  ncol = ncol(Yc))
        #    tmp[,var.idx] <- FSC
        #    FSM.g[[p]] <- tmp
        # }

        # factor scores for this pattern
        FS.g[Mp$case.idx[[p]], ] <- t(FSC %*% t(Oc) + EETA.g)

        # SE?
        if (se == "standard") {
          tmp <- (MASS::ginv(t(lambda) %*% Sigma_22.inv %*% lambda)
          - VETA.g)
          tmp.d <- diag(tmp)
          tmp.d[tmp.d < 1e-05] <- as.numeric(NA)

          # all cases in this pattern get the same SEs
          SE.g[Mp$case.idx[[p]], ] <- matrix(sqrt(tmp.d),
            nrow = length(Mp$case.idx[[p]]),
            ncol = ncol(SE.g), byrow = TRUE
          )
        }

        # ACOV?
        if (acov == "standard") {
          ACOV.g[[p]] <- tmp # for this pattern
        }
      }

      # what about FSM? There is no single one, but as many as patterns
      # if(fsm) {
      #    # use 'global' version (just like in complete case)
      #    FSM[[g]] <- ( MASS::ginv(t(LAMBDA.g) %*% Sigma.inv.g %*%
      #                    LAMBDA.g) %*% t(LAMBDA.g) %*% Sigma.inv.g )
      # }
    } else {
      # compute factor scores
      FS.g <- t(FSC %*% t(Yc) + EETA.g)
    }

    # replace values in dummy lv's by their observed counterpart
    if (length(lavmodel@ov.y.dummy.lv.idx[[g]]) > 0L && level == 1L) {
      FS.g[, lavmodel@ov.y.dummy.lv.idx[[g]]] <-
        data.obs[[g]][, lavmodel@ov.y.dummy.ov.idx[[g]], drop = FALSE]
    }
    if (length(lavmodel@ov.x.dummy.lv.idx[[g]]) > 0L && level == 1L) {
      FS.g[, lavmodel@ov.x.dummy.lv.idx[[g]]] <-
        data.obs[[g]][, lavmodel@ov.x.dummy.ov.idx[[g]], drop = FALSE]
    }

    FS[[g]] <- FS.g

    # FSM
    if (fsm) {
      FSM[[g]] <- FSM.g
    }

	# REL
	if (rel) {
	  REL[[g]] <- REL.g
	}

    # standard error
    if (se == "standard" && !transform) {
      if (lavdata@missing %in% c("ml", "ml.x")) {
        SE[[g]] <- SE.g
        if (acov == "standard") {
          ACOV[[g]] <- ACOV.g
        }
      } else { # complete data

        # the traditional formula is:
        #     solve(t(lambda) %*% solve(theta) %*% lambda)
        # but we replace it by
        #     solve( t(lambda) %*% solve(sigma) %*% lambda ) - psi
        # to handle negative variances
        # in addition, we use ginv
        tmp <- (MASS::ginv(t(LAMBDA.g) %*% Sigma.inv.g %*% LAMBDA.g)
        - VETA.g)
        tmp.d <- diag(tmp)
        tmp.d[tmp.d < 1e-05] <- as.numeric(NA)
        SE[[g]] <- matrix(sqrt(tmp.d), nrow = 1L)

        # return full sampling covariance matrix?
        if (acov == "standard") {
          ACOV[[g]] <- tmp
        }
      }
    } # se
  } # g

  if (fsm) {
    attr(FS, "fsm") <- FSM
  }
  if (rel) {
    attr(FS, "rel") <- REL
  }
  if (se != "none") {
    attr(FS, "se") <- SE
    # return full sampling covariance matrix?
    if (acov == "standard") {
      attr(FS, "acov") <- ACOV
    }
  }

  FS
}

# factor scores - EBM or ML
lav_predict_eta_ebm_ml <- function(lavobject = NULL, # for convenience
                                   # sub objects
                                   lavmodel = NULL, lavdata = NULL,
                                   lavsamplestats = NULL,
                                   # optional new data
                                   data.obs = NULL, eXo = NULL,
                                   se = "none", acov = "none", level = 1L,
                                   ML = FALSE,
                                   optim.method = "bfgs") {
  optim.method <- tolower(optim.method)

  stopifnot(optim.method %in% c("nlminb", "bfgs"))

  ### FIXME: if all indicators of a factor are normal, can we not
  ###        just use the `classic' regression method??
  ###        (perhaps after whitening, to get uncorrelated factors...)

  # full object?
  if (inherits(lavobject, "lavaan")) {
    lavmodel <- lavobject@Model
    lavdata <- lavobject@Data
    lavsamplestats <- lavobject@SampleStats
  } else {
    stopifnot(
      !is.null(lavmodel), !is.null(lavdata),
      !is.null(lavsamplestats)
    )
  }

  # new data?
  if (is.null(data.obs)) {
    data.obs <- lavdata@X
  }
  if (is.null(eXo)) {
    eXo <- lavdata@eXo
  }

  # se?
  if (acov != "none") {
    se <- acov # ACOV implies SE
  }
  # if(se != "none") {
  #    warning("lavaan WARNING: standard errors are not available (yet) for the non-normal case")
  # }

  VETAx <- lav_model_vetax(lavmodel = lavmodel)
  VETAx.inv <- VETAx
  for (g in seq_len(lavdata@ngroups)) {
    if (nrow(VETAx[[g]]) > 0L) {
      VETAx.inv[[g]] <- solve(VETAx[[g]])
    }
  }
  EETAx <- lav_model_eetax(
    lavmodel = lavmodel, lavsamplestats = lavsamplestats,
    eXo = eXo, nobs = lapply(data.obs, NROW),
    remove.dummy.lv = TRUE
  ) ## FIXME?
  TH <- lav_model_th(lavmodel = lavmodel, delta = FALSE)
  THETA <- lav_model_theta(lavmodel = lavmodel)

  # check for zero entries in THETA (new in 0.6-4)
  for (g in seq_len(lavdata@ngroups)) {
    if (any(diag(THETA[[g]]) == 0)) {
      lav_msg_stop(gettext(
        "(residual) variance matrix THETA contains zero elements
        on the diagonal."))
    }
  }

  # local objective function: x = lv values
  f.eta.i <- function(x, y.i, x.i, mu.i) {
    # add 'dummy' values (if any) for ov.y
    if (length(lavmodel@ov.y.dummy.lv.idx[[g]]) > 0L) {
      x2 <- c(x - mu.i, data.obs[[g]][i,
        lavmodel@ov.y.dummy.ov.idx[[g]],
        drop = FALSE
      ])
    } else {
      x2 <- x - mu.i
    }

    # conditional density of y, given eta.i(=x)
    log.fy <- lav_predict_fy_eta.i(
      lavmodel = lavmodel,
      lavdata = lavdata,
      lavsamplestats = lavsamplestats,
      y.i = y.i,
      x.i = x.i,
      eta.i = matrix(x2, nrow = 1L), # <---- eta!
      theta.sd = theta.sd,
      th = th,
      th.idx = th.idx,
      log = TRUE
    )

    if (ML) {
      # NOTE: 'true' ML is simply  -1*sum(log.fy)
      #  - but there is no upper/lower bound for the extrema:
      #    a pattern of all (in)correct drives the 'theta' parameter
      #    towards +/- Inf
      # - therefore, we add a vague prior, just to stabilize
      #
      diff <- t(x) - mu.i
      V <- diag(length(x)) * 1e-05
      tmp <- as.numeric(0.5 * diff %*% V %*% t(diff))
      out <- 1 + tmp - sum(log.fy, na.rm = TRUE)
    } else {
      diff <- t(x) - mu.i
      V <- VETAx.inv[[g]]
      tmp <- as.numeric(0.5 * diff %*% V %*% t(diff))
      out <- tmp - sum(log.fy, na.rm = TRUE)
    }
    out
  }

  FS <- vector("list", length = lavdata@ngroups)
  for (g in seq_len(lavdata@ngroups)) {
    nfac <- ncol(VETAx[[g]])
    nfac2 <- nfac
    if (length(lavmodel@ov.y.dummy.lv.idx[[g]]) > 0L) {
      nfac2 <- nfac2 + length(lavmodel@ov.y.dummy.lv.idx[[g]])
    }
    FS[[g]] <- matrix(as.numeric(NA), nrow(data.obs[[g]]), nfac2)

    # special case: no regular lv's
    if (nfac == 0) {
      # impute dummy ov.y (if any)
      FS[[g]][, lavmodel@ov.y.dummy.ov.idx[[g]]] <-
        data.obs[[g]][, lavmodel@ov.y.dummy.ov.idx[[g]], drop = FALSE]
      next
    }

    ## FIXME: factor scores not identical (but close) to Mplus
    #         if delta elements not equal to 1??
    mm.in.group <- 1:lavmodel@nmat[g] + cumsum(c(0, lavmodel@nmat))[g]
    MLIST <- lavmodel@GLIST[mm.in.group]

    # check for negative values
    neg.var.idx <- which(diag(THETA[[g]]) < 0)
    if (length(neg.var.idx) > 0) {
      lav_msg_warn(
        gettext("factor scores could not be computed due to at least
                one negative (residual) variance"))
      next
    }

    # common values
    theta.sd <- sqrt(diag(THETA[[g]]))
    th <- TH[[g]]
    th.idx <- lavmodel@th.idx[[g]]

    # casewise for now
    N <- nrow(data.obs[[g]])
    for (i in 1:N) {
      # eXo?
      if (!is.null(eXo[[g]])) {
        x.i <- eXo[[g]][i, , drop = FALSE]
      } else {
        x.i <- NULL
      }
      mu.i <- EETAx[[g]][i, , drop = FALSE]
      y.i <- data.obs[[g]][i, , drop = FALSE]

      ### DEBUG ONLY:
      # cat("i = ", i, "mu.i = ", mu.i, "\n")

      START <- numeric(nfac) # initial values for eta

      if (!all(is.na(y.i))) {
        # find best values for eta.i
        if (optim.method == "nlminb") {
          out <- nlminb(
            start = START, objective = f.eta.i,
            gradient = NULL, # for now
            control = list(rel.tol = 1e-8),
            y.i = y.i, x.i = x.i, mu.i = mu.i
          )
        } else if (optim.method == "bfgs") {
          out <- optim(
            par = START, fn = f.eta.i,
            gr = NULL,
            control = list(reltol = 1e-8, fnscale = 1.1),
            method = "BFGS",
            y.i = y.i, x.i = x.i, mu.i = mu.i
          )
        }
        if (out$convergence == 0L) {
          eta.i <- out$par
        } else {
          eta.i <- rep(as.numeric(NA), nfac)
        }
      } else {
        eta.i <- rep(as.numeric(NA), nfac)
      }

      # add dummy ov.y lv values
      if (length(lavmodel@ov.y.dummy.lv.idx[[g]]) > 0L) {
        eta.i <- c(eta.i, data.obs[[g]][i,
          lavmodel@ov.y.dummy.ov.idx[[g]],
          drop = FALSE
        ])
      }

      FS[[g]][i, ] <- eta.i
    }
  }

  FS
}

# predicted value for response y*_i, conditional on the predicted latent
# variable scores
# `measurement part':
#     y*_i = nu + lambda eta_i + K x_i + epsilon_i
#
#    where eta_i = latent variable value for i (either given or from predict)
#
# Two types: 1) nrow(ETA) = nrow(X) (factor scores)
#            2) nrow(ETA) = 1L (given values)
#
# in both cases, we return [nobs x nvar] matrix per group
lav_predict_yhat <- function(lavobject = NULL, # for convience
                             # sub objects
                             lavmodel = NULL, lavdata = NULL,
                             lavsamplestats = NULL,
                             lavimplied = NULL,
                             # new data
                             data.obs = NULL, eXo = NULL,
                             # ETA values
                             ETA = NULL,
                             # options
                             method = "EBM",
                             duplicate = FALSE,
                             optim.method = "bfgs",
                             fsm = FALSE,
                             resid.flag = FALSE) {
  # full object?
  if (inherits(lavobject, "lavaan")) {
    lavmodel <- lavobject@Model
    lavdata <- lavobject@Data
    lavsamplestats <- lavobject@SampleStats
    lavimplied <- lavobject@implied
  } else {
    stopifnot(
      !is.null(lavmodel), !is.null(lavdata),
      !is.null(lavsamplestats), !is.null(lavimplied)
    )
  }

  # new data?
  if (is.null(data.obs)) {
    data.obs <- lavdata@X
  }
  if (is.null(eXo)) {
    eXo <- lavdata@eXo
  }

  # do we get values for ETA? If not, use `predict' to get plausible values
  if (is.null(ETA)) {
    ETA <- lav_predict_eta(
      lavobject = NULL, lavmodel = lavmodel,
      lavdata = lavdata, lavsamplestats = lavsamplestats,
      lavimplied = lavimplied,
      data.obs = data.obs, eXo = eXo, method = method,
      optim.method = optim.method, fsm = fsm
    )
    FSM <- attr(ETA, "fsm")
  } else {
    # matrix
    if (is.matrix(ETA)) { # user-specified?
      if (nrow(ETA) == 1L) {
        tmp <- matrix(ETA, lavsamplestats@ntotal, length(ETA),
          byrow = TRUE
        )
      } else if (nrow(ETA) != lavsamplestats@ntotal) {
        lav_msg_stop(gettext("nrow(ETA) != lavsamplestats@ntotal"))
      } else {
        tmp <- ETA
      }
      ETA <- lapply(1:lavdata@ngroups, function(i) tmp[lavdata@case.idx[[i]], ])
      # vector: just 1 row of factor-scores
    } else if (is.numeric(ETA)) {
      # convert to matrix
      tmp <- matrix(ETA, lavsamplestats@ntotal, length(ETA), byrow = TRUE)
      ETA <- lapply(1:lavdata@ngroups, function(i) tmp[lavdata@case.idx[[i]], ])
    } else if (is.list(ETA)) {
      stopifnot(lavdata@ngroups == length(ETA))
    }
  }

  YHAT <- lav_model_yhat(
    lavmodel = lavmodel, GLIST = NULL,
    lavsamplestats = lavsamplestats, eXo = eXo,
    nobs = lapply(data.obs, NROW),
    ETA = ETA, duplicate = duplicate
  )

  # if conditional.x, paste eXo
  if (lavmodel@categorical && !is.null(eXo)) {
    YHAT <- lapply(seq_len(lavdata@ngroups), function(g) {
      ret <- cbind(YHAT[[g]], eXo[[g]])
      ret
    })
  }

  # residuals? compute y - yhat
  if (resid.flag) {
    RES <- lapply(seq_len(lavdata@ngroups), function(g) {
      ret <- data.obs[[g]] - YHAT[[g]]
      ret
    })
  } else {
    RES <- YHAT
  }

  # fsm?
  if (fsm) {
    attr(RES, "fsm") <- FSM
  }

  RES
}

# conditional density y -- assuming independence!!
# f(y_i | eta_i, x_i) for EACH item
#
lav_predict_fy <- function(lavobject = NULL, # for convience
                           # sub objects
                           lavmodel = NULL, lavdata = NULL,
                           lavsamplestats = NULL,
                           lavimplied = NULL,
                           # new data
                           data.obs = NULL, eXo = NULL,
                           # ETA values
                           ETA = NULL,
                           # options
                           method = "EBM",
                           log. = FALSE,
                           optim.method = "bfgs") {
  # full object?
  if (inherits(lavobject, "lavaan")) {
    lavmodel <- lavobject@Model
    lavdata <- lavobject@Data
    lavsamplestats <- lavobject@SampleStats
    lavimplied <- lavobject@implied
  } else {
    stopifnot(
      !is.null(lavmodel), !is.null(lavdata),
      !is.null(lavsamplestats), !is.null(lavimplied)
    )
  }

  # new data?
  if (is.null(data.obs)) {
    data.obs <- lavdata@X
  }
  if (is.null(eXo)) {
    eXo <- lavdata@eXo
  }

  # we need the YHATs (per group)
  YHAT <- lav_predict_yhat(
    lavobject = NULL, lavmodel = lavmodel,
    lavdata = lavdata, lavsamplestats = lavsamplestats,
    lavimplied = lavimplied,
    data.obs = data.obs, eXo = eXo, ETA = ETA, method = method,
    duplicate = FALSE, optim.method = optim.method
  )

  THETA <- lav_model_theta(lavmodel = lavmodel)
  TH <- lav_model_th(lavmodel = lavmodel, delta = FALSE)

  FY <- vector("list", length = lavdata@ngroups)
  for (g in seq_len(lavdata@ngroups)) {
    FY[[g]] <- lav_predict_fy_internal(
      X = data.obs[[g]], yhat = YHAT[[g]],
      TH = TH[[g]], THETA = THETA[[g]],
      num.idx = lavmodel@num.idx[[g]],
      th.idx = lavmodel@th.idx[[g]],
      link = lavmodel@link, log. = log.
    )
  }

  FY
}


# single group, internal function
lav_predict_fy_internal <- function(X = NULL, yhat = NULL,
                                    TH = NULL, THETA = NULL,
                                    num.idx = NULL, th.idx = NULL,
                                    link = NULL, log. = FALSE) {
  # shortcuts
  theta.var <- diag(THETA)

  # check size YHAT (either 1L or Nobs rows)
  if (!(nrow(yhat) == 1L || nrow(yhat) == nrow(X))) {
    lav_msg_stop(gettext("nrow(YHAT[[g]]) not 1L and not nrow(X))"))
  }

  FY.group <- matrix(0, nrow(X), ncol(X))
  # if(NORMAL) {
  #    if(nrow(yhat) == nrow(X)) {
  #        tmp <- (X - yhat)^2
  #    } else {
  #        tmp <- sweep(X, MARGIN=2, STATS=yhat, FUN="-")^2
  #    }
  #    tmp1 <- sweep(tmp, MARGIN=2, theta.var, "/")
  #    tmp2 <- exp( -0.5 * tmp1 )
  #    tmp3 <- sweep(tmp2, MARGIN=2, sqrt(2*pi*theta.var), "/")
  #    if(log.) {
  #        FY.group <- log(tmp3)
  #    } else {
  #        FY.group <- tmp3
  #    }
  # } else {
  # mixed items

  ord.idx <- unique(th.idx[th.idx > 0L])

  # first, NUMERIC variables
  if (length(num.idx) > 0L) {
    for (v in num.idx) {
      FY.group[, v] <- dnorm(X[, v],
        # YHAT may change or not per case
        mean = yhat[, v],
        sd   = sqrt(theta.var[v]),
        log  = log.
      )
    }
  }

  # second, ORDERED variables
  for (v in ord.idx) {
    th.y <- TH[th.idx == v]
    TH.Y <- c(-Inf, th.y, Inf)
    ncat <- length(th.y) + 1L
    fy <- numeric(ncat)
    theta.v <- sqrt(theta.var[v])
    yhat.v <- yhat[, v]

    # two cases: yhat.v is a scalar, or has length = nobs
    fy <- matrix(0, nrow = length(yhat.v), ncol = ncat)

    # for each category
    for (k in seq_len(ncat)) {
      if (link == "probit") {
        fy[, k] <- pnorm((TH.Y[k + 1] - yhat.v) / theta.v) -
          pnorm((TH.Y[k] - yhat.v) / theta.v)
      } else if (link == "logit") {
        fy[, k] <- plogis((TH.Y[k + 1] - yhat.v) / theta.v) -
          plogis((TH.Y[k] - yhat.v) / theta.v)
      } else {
        lav_msg_stop(gettext("link must be probit or logit"))
      }
    }

    # underflow
    idx <- which(fy < .Machine$double.eps)
    if (length(idx) > 0L) {
      fy[idx] <- .Machine$double.eps
    }

    # log?
    if (log.) {
      fy <- log(fy)
    }

    # case-wise expansion/selection
    if (length(yhat.v) == 1L) {
      # expand category probabilities for all observations
      FY.group[, v] <- fy[1L, X[, v]]
    } else {
      # select correct category probability per observation
      FY.group[, v] <- fy[cbind(seq_len(nrow(fy)), X[, v])]
    }
  } # ord

  FY.group
}



# conditional density y -- assuming independence!!
# f(y_i | eta_i, x_i)
#
# but for a SINGLE observation y_i (and x_i), for given values of eta_i
#
lav_predict_fy_eta.i <- function(lavmodel = NULL, lavdata = NULL,
                                 lavsamplestats = NULL,
                                 y.i = NULL, x.i = NULL,
                                 eta.i = NULL, theta.sd = NULL, g = 1L,
                                 th = NULL, th.idx = NULL, log = TRUE) {
  mm.in.group <- 1:lavmodel@nmat[g] + cumsum(c(0, lavmodel@nmat))[g]
  MLIST <- lavmodel@GLIST[mm.in.group]

  # linear predictor for all items
  YHAT <-
    lav_lisrel_eyetax(
      MLIST = MLIST,
      eXo = x.i,
      ETA = eta.i,
      sample.mean = lavsamplestats@mean[[g]],
      ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
      ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
      ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
      ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]],
      delta = FALSE
    )

  # P(y_i | eta_i, x_i) for all items
  if (all(lavdata@ov$type == "numeric")) {
    # NORMAL case
    FY <- dnorm(y.i, mean = YHAT, sd = theta.sd, log = log)
  } else {
    FY <- numeric(lavmodel@nvar[g])
    for (v in seq_len(lavmodel@nvar[g])) {
      if (lavdata@ov$type[v] == "numeric") {
        ### FIXME!!! we can do all numeric vars at once!!
        FY[v] <- dnorm(y.i[v],
          mean = YHAT[v], sd = theta.sd[v],
          log = log
        )
      } else if (lavdata@ov$type[v] == "ordered") {
        # handle missing value
        if (is.na(y.i[v])) {
          FY[v] <- as.numeric(NA)
        } else {
          th.y <- th[th.idx == v]
          TH.Y <- c(-Inf, th.y, Inf)
          k <- y.i[v]
          p1 <- pnorm((TH.Y[k + 1] - YHAT[v]) / theta.sd[v])
          p2 <- pnorm((TH.Y[k] - YHAT[v]) / theta.sd[v])
          prob <- (p1 - p2)
          if (prob < .Machine$double.eps) {
            prob <- .Machine$double.eps
          }
          if (log) {
            FY[v] <- log(prob)
          } else {
            FY[v] <- prob
          }
        }
      } else {
        lav_msg_stop(gettextf("unknown type: `%1$s' for variable: %2$s",
          lavdata@ov$type[v], lavdata@ov$name[v])
        )
      }
    }
  }

  FY
}

# compute `transformation' matrix to convert regression factor scores
# to (Green's) correlation-preserving factor scores
lav_predict_tmat_green <- function(lavobject = NULL,
                                   lavmodel = NULL, lavimplied = NULL) {

  if (!is.null(lavobject)) {
    lavmodel <- lavobject@Model
    lavimplied <- lavobject@implied
  }

  if (is.null(lavimplied) || length(lavimplied) == 0L) {
    lavimplied <- lav_model_implied(lavmodel)
  }
  if (lavmodel@conditional.x) {
    lavimplied <- lav_model_implied_cond2uncond(lavimplied)
  }
  Sigma <- lavimplied$cov
  VETA <- lav_model_veta(lavmodel = lavmodel, remove.dummy.lv = FALSE)
  LAMBDA <- lav_model_lambda(lavmodel, remove.dummy.lv = FALSE)

  nblocks <- lavmodel@nblocks
  tmat <- vector("list", length = nblocks)

  # compute tmat per block
  for(b in seq_len(nblocks)) {
    Sigma.b <- Sigma[[b]]
    Sigma.b.inv <- solve(Sigma.b)
    Veta <- VETA[[b]]
    Veta.sqrt <- lav_matrix_symmetric_sqrt(Veta)
    Veta32 <- Veta %*% Veta.sqrt
    Lambda <- LAMBDA[[b]]
    tmp <- Veta32 %*% t(Lambda) %*% Sigma.b.inv %*% Lambda %*% Veta32
    tmp.inv.sqrt <- lav_matrix_symmetric_sqrt(solve(tmp))
    tmat[[b]] <- Veta.sqrt %*% tmp.inv.sqrt %*% Veta.sqrt
  }

  tmat
}

# compute `transformation' matrix to convert Bartlett factor scores
# to (Krijnen/McDonald) correlation-preserving factor scores
lav_predict_tmat_det <- function(lavobject = NULL,
                                 lavmodel = NULL, lavimplied = NULL) {

  if (!is.null(lavobject)) {
    lavmodel <- lavobject@Model
    lavimplied <- lavobject@implied
  }

  if (is.null(lavimplied) || length(lavimplied) == 0L) {
    lavimplied <- lav_model_implied(lavmodel)
  }
  if (lavmodel@conditional.x) {
    lavimplied <- lav_model_implied_cond2uncond(lavimplied)
  }
  Sigma <- lavimplied$cov
  VETA <- lav_model_veta(lavmodel = lavmodel, remove.dummy.lv = FALSE)
  LAMBDA <- lav_model_lambda(lavmodel, remove.dummy.lv = FALSE)

  nblocks <- lavmodel@nblocks
  tmat <- vector("list", length = nblocks)

  # compute tmat per block
  for(b in seq_len(nblocks)) {
    Sigma.b <- Sigma[[b]]
    Sigma.b.inv <- solve(Sigma.b)
    Veta <- VETA[[b]]
    Veta.sqrt <- lav_matrix_symmetric_sqrt(Veta)
    Veta.inv.sqrt <- lav_matrix_symmetric_sqrt(solve(Veta))
    Lambda <- LAMBDA[[b]]
    tmp <- Veta.sqrt %*% t(Lambda) %*% Sigma.b.inv %*% Lambda %*% Veta.sqrt
    tmp.sqrt <- lav_matrix_symmetric_sqrt(tmp)
    tmat[[b]] <- Veta.sqrt %*% tmp.sqrt %*% Veta.inv.sqrt
  }

  tmat
}

# single block only, for internal use in lav_sam_step1_local()
lav_predict_tmat_det_internal <- function(Sigma = NULL, Veta = NULL,
                                          Lambda = NULL) {
    Sigma.inv <- solve(Sigma)
    Veta.sqrt <- lav_matrix_symmetric_sqrt(Veta)
    Veta.inv.sqrt <- lav_matrix_symmetric_sqrt(solve(Veta))
    tmp <- Veta.sqrt %*% t(Lambda) %*% Sigma.inv %*% Lambda %*% Veta.sqrt
    tmp.sqrt <- lav_matrix_symmetric_sqrt(tmp)
    tmat <- Veta.sqrt %*% tmp.sqrt %*% Veta.inv.sqrt
    tmat
}


# SAM: a Structural After Measurement approach
#
# Yves Rosseel & Wen-Wei Loh, Feb-May 2019

# local vs global sam
# local sam = alternative for FSR+Croon
# - but no need to compute factor scores or corrections
# global sam = (old) twostep
# - but we can also take a 'local' perspective

# restrictions:
#
# local and global:
#  - all (measured) latent variables must have indicators that are observed
#    update: higher-order measurement models are supported in local SAM (0.6-20)
# local:
#  - only if LAMBDA is of full column rank (eg no SRM, no bi-factor, no MTMM)
#  - if multiple groups: each group has the same set of latent variables!
#  - global approach is used to compute corrected two-step standard errors
#    update: se = "local" is truely local, and uses 'Gamma' as an additional
#            ingredient; Gamma reflects the sampling variability of the
#            sample statistics (VETA and EETA)

# YR 12 May 2019 - first version
# YR 22 May 2019 - merge sam/twostep (call it 'local' vs 'global' sam)

# YR 27 June 2021 - prepare for `public' release
#                 - add Fuller (1987) 'lambda' correction if (MSM - MTM) is not
#                   positive definite
#                 - se = "none" now works
#                 - store 'local' information in @internal slot (for printing)

# YR 16 Oct 2021 - if an indicator is also a predictor/outcome in the
#                  structural part, treat it as an observed predictor
#                  without measurement error in the second step
#                  (ie, set THETA element to zero)

# YR 03 Dec 2022 - allow for sam.method = "fsr" and se = "naive"
#                - add alpha.correction= argument (for small sample correction)

# YR 21 May 2023 - allow for latent quadratic/interaction terms in the
#                  structural part (assuming the errors are normal, for now)

# YR 25 May 2023 - restructure code into multiple files
#                - rename veta.force.pd -> lambda.correction
#                - move alpha.correction= argument to local.options

# YR 09 Nov 2024 - add se = "bootstrap"
# YR 14 Nov 2024 - add se = "local"
# YR 01 Mar 2025 - allow for higher-order measurement models in local SAM
# YR 25 Mar 2025 - add sam.method = "cFSR" (using correlation-preserving FS)
# YR 15 Apr 2025 - add se = "twostep.robust"

# twostep = wrapper for global sam
twostep <- function(model = NULL, data = NULL, cmd = "sem",
                    mm.list = NULL, mm.args = list(), struc.args = list(),
                    ..., # global options
                    output = "lavaan") {
  sam(
    model = model, data = data, cmd = cmd, mm.list = mm.list,
    mm.args = mm.args, struc.args = struc.args,
    sam.method = "global", # or global
    ..., # global options
    output = output
  )
}

# fsr = wrapper for local sam
# TODO


sam <- function(model = NULL,
                data = NULL,
                cmd = "sem",
                se = "twostep",
                mm.list = NULL,
                mm.args = list(bounds = "wide.zerovar"),
                struc.args = list(estimator = "ML"),
                sam.method = "local", # or "global", or "fsr", or "cfsr"
                ..., # common options
                local.options = list(
                  M.method = "ML", # mapping matrix
                  lambda.correction = TRUE,
                  alpha.correction = 0L, # 0 -> (N-1)
                  twolevel.method = "h1"
                ),
                # h1, anova, mean
                global.options = list(), # not used for now
                bootstrap = list(R = 1000L, type = "ordinary",
                                      show.progress = FALSE),
                output = "lavaan",
                bootstrap.args = bootstrap) {
  # "bootstrap" is the new way to specify arguments, replacing bootstrap.args
  if (!missing(bootstrap.args)) {
    lav_msg_warn(gettext(
      "'bootstrap.args' is deprecated; please use 'bootstrap' instead."))
    bootstrap <- bootstrap.args
  }

  # check model= argument
  has.sam.object.flag <- FALSE
  if (inherits(model, "lavaan") && !is.null(model@internal$sam.method)) {
    has.sam.object.flag <- TRUE
  }

  # check sam.method
  sam.method <- tolower(sam.method)
  if (!sam.method %in% c("local", "global", "fsr", "cfsr")) {
    lav_msg_stop(gettextf("unknown option for sam.method: [%s]",
                          "available options are local, global, fsr and cfs."))
  }

  # ------------- handling of warn/debug/verbose switches ----------
  dotdotdot <- list(...)
  if( length(dotdotdot) > 0L) {
    if (!is.null(dotdotdot$debug)) {
     current.debug <- lav_debug()
      if (lav_debug(dotdotdot$debug))
        on.exit(lav_debug(current.debug), TRUE)
      dotdotdot$debug <- NULL
      if (lav_debug()) {
        dotdotdot$warn <- TRUE       # force warnings if debug
        dotdotdot$verbose <- TRUE    # force verbose if debug
      }
    }
    if (!is.null(dotdotdot$warn)) {
      current.warn <- lav_warn()
      if (lav_warn(dotdotdot$warn))
        on.exit(lav_warn(current.warn), TRUE)
      dotdotdot$warn <- NULL
    }
    if (!is.null(dotdotdot$verbose)) {
      current.verbose <- lav_verbose()
      if (lav_verbose(dotdotdot$verbose))
        on.exit(lav_verbose(current.verbose), TRUE)
      dotdotdot$verbose <- NULL
    }
    # check for conditional.x= argument
    # if (!sam.method == "global" && !is.null(dotdotdot$conditional.x) &&
    #     dotdotdot$conditional.x) {
    #   lav_msg_warn(gettext(
    #     "local sam() does not support conditional.x = TRUE (yet) -> switching to
    #       conditional.x = FALSE"))
    #   dotdotdot$conditional.x <- FALSE
    # }
    # check for orthogonal= argument
    if (!is.null(dotdotdot$orthogonal) &&
        dotdotdot$orthogonal &&
        sam.method != "global") {
      lav_msg_warn(gettext(
        "local sam does not support orthogonal = TRUE -> switching to
         global sam"))
     sam.method <- "global"
    }
  } # length(dotdotdot) > 0L

  # check output= argument
  output <- tolower(output)
  if (output %in% c("list", "list.step1.only", "lavaan")) {
    # nothing to do
  } else {
    lav_msg_stop(gettext("output should be \"list\" or \"lavaan.\""))
  }

  #

  # check se= argument
  if (!missing(se)) {
    se <- tolower(se)
    # aliases
    if (se %in% c("two-step", "two_step", "two.step")) {
      se <- "twostep"
    } else if(se %in% c("two-step-robust", "two-step.robust",
                        "two_step_robust", "two.step.robust",
                        "twostep.robust")) {
      se <- "twostep.robust"
    }
    else if (se %in% c("ij", "local")) {
      se <- "local"
    }
    # check if valid
    if (!se %in% c("standard", "naive", "twostep", "local", "local.nt",
                   "twostep.robust", "bootstrap", "none")) {
      lav_msg_stop(gettext(
        "se= argument must be twostep, twostep.robust, bootstrap, or local"))
    }
    # check for local
    if (se %in% c("local", "local.nt")) {
      if (!sam.method %in% c("local", "fsr", "cfsr")) { # for now
        lav_msg_stop(gettext("local se only available if sam.method is local, fsr, or cfsr"))
      }
    }
  }
  # default is twostep

  # check for gamma.unbiased
  if (is.null(dotdotdot$gamma.unbiased)) {
     # put in TRUE in dotdotdot # lavaan default is still FALSE
     dotdotdot$gamma.unbiased <- TRUE
  }


  ###############################################
  # STEP 0: process full model, without fitting #
  ###############################################
  if (has.sam.object.flag) {
    FIT <- model
    # restore options
    FIT@Options <- FIT@internal$sam.lavoptions
    # extract other argments from FIT@internal, unless specified as arguments
    if (missing(mm.list)){
      mm.list <- FIT@internal$sam.mm.list
    }
    if (missing(mm.args)){
      mm.args <- FIT@internal$sam.mm.args
    }
    if (missing(struc.args)) {
      struc.args <- FIT@internal$sam.struc.args
    }
    if (missing(sam.method)) {
      sam.method <- FIT@internal$sam.method
    }
    if (missing(local.options)) {
      local.options <- FIT@internal$sam.local.options
    }
    if (missing(global.options)) {
      global.options <- FIT@internal$sam.global.options
    }
    if (missing(se)) {
      se <- FIT@Options$se
    } else {
      FIT@Options$se <- se
    }
    if (missing(cmd)) {
      cmd <- FIT@internal$sam.cmd
    }
    # remove @internal slot
    FIT@internal <- list()
  } else {
    FIT <- lav_sam_step0(
      cmd = cmd, model = model, data = data, se = se,
      sam.method = sam.method, dotdotdot = dotdotdot
    )

    # check for data.type == "none"
    if (FIT@Data@data.type == "none") {
      # we are done; perhaps we only wished to create a FIT object?
      return(FIT)
      #lav_msg_stop(gettext("no data or sample statistics are provided."))
    }

    # check if we have categorical data
    if (FIT@Model@categorical) {
      # switch to M.method = "ULS"
      local.options[["M.method"]] <- "ULS"
      # if sam.method = "global", force estimator to DWLS in struc par
  	  if (sam.method == "global" &&
  	      !is.null(struc.args[["estimator"]]) &&
    	    struc.args[["estimator"]] == "ML") {
          struc.args[["estimator"]] <- "DWLS"
      }
    }

    # check if we have latent interactions
    lv.interaction.flag <- FALSE
    if (length(unlist(FIT@pta$vnames$lv.interaction)) > 0L) {
      lv.interaction.flag <- TRUE
      if (!se %in% c("none", "bootstrap")) {
        se <- "local"
        FIT@Options$se <- se
      }
    }

    # check for multiple groups/blocks
    if (FIT@Model@nblocks > 1L && se == "local") {
      lav_msg_stop(gettext("se = \"local\" not available (yet) if multiple
                            blocks (groups, levels) are involved."))
    }
  }

  lavoptions <- lavInspect(FIT, "options")
  if (lav_verbose()) {
    cat("This is sam using sam.method = ", sam.method, ".\n", sep = "")
  }

  ##############################################
  # STEP 1: fit each measurement model (block) #
  ##############################################
  if (lav_verbose()) {
    cat("Fitting the measurement part:\n")
  }
  STEP1 <- lav_sam_step1(
    cmd = cmd, mm.list = mm.list, mm.args = mm.args,
    FIT = FIT, sam.method = sam.method
  )

  ##################################################
  # STEP 1b: compute Var(eta) and E(eta) per block #
  #          only needed for local approach!       #
  ##################################################
  if (sam.method %in% c("local", "fsr", "cfsr")) {
    # default local.options
    local.opt <- list(
      M.method = "ML",
      lambda.correction = TRUE,
      alpha.correction = 0L,
      twolevel.method = "h1"
    )
    local.options <- modifyList(local.opt, local.options,
      keep.null = FALSE
    )

    # collect COV/YBAR sample statistics per block from FIT
    out <- lav_sam_get_cov_ybar(FIT = FIT, local.options = local.options)
    STEP1$COV  <- out$COV
    STEP1$YBAR <- out$YBAR

    # compute EETA/VETA
    STEP1 <- lav_sam_step1_local(
      STEP1 = STEP1, FIT = FIT,
      sam.method = sam.method,
      local.options = local.options,
      return.cov.iveta2 = (se %in% c("local", "local.nt"))
    )
  }

  ##################################################
  # STEP 1c: jacobian of vech(VETA) = f(vech(S))   #
  #          only needed for local approach!       #
  #          only if se = "local"                  #
  ##################################################
  if (se %in% c("local", "local.nt")) {
    Gamma.eta <- vector("list", length = FIT@Data@ngroups)
    if (lv.interaction.flag) {
      for (g in seq_len(FIT@Data@ngroups)) { # group or block
        # initial Gamma.eta
        Gamma.eta.init <- STEP1$COV.IVETA2[[g]]
        # compute 'additional variability' due to step1
        Gamma.eta.add <- lav_sam_gamma_add(STEP1 = STEP1, FIT = FIT, group = g)
        Gamma.eta[[g]] <- Gamma.eta.init + Gamma.eta.add
      }
    } else {
      JAC <- lav_sam_step1_local_jac(STEP1 = STEP1, FIT = FIT)
      if (se == "local") {
        Gamma <- FIT@SampleStats@NACOV
      } else if (se == "local.nt") {
        Gamma <- lav_object_gamma(lavobject = FIT, ADF = FALSE)
      }

      for (g in seq_len(FIT@Data@ngroups)) {
        Gamma.eta[[g]] <- JAC[[g]] %*% Gamma[[g]] %*% t(JAC[[g]])
      }
      STEP1$JAC <- JAC
    } # no lv-interaction
    STEP1$Gamma.eta <- Gamma.eta
  }

  if (output == "list.step1.only") {
    # stop here, return interim results
    return(STEP1)
  }

  ####################################
  # STEP 2: estimate structural part #
  ####################################

  STEP2 <- lav_sam_step2(
    STEP1 = STEP1, FIT = FIT,
    sam.method = sam.method, struc.args = struc.args
  )

  # make sure step1.free.idx and step2.free.idx are disjoint
  both.idx <- which(STEP1$step1.free.idx %in% STEP2$step2.free.idx)
  if (length(both.idx) > 0L) {
    STEP1$step1.free.idx <- STEP1$step1.free.idx[-both.idx]
    # STEP1$Sigma.11[both.idx,] <- 0
    # STEP1$Sigma.11[,both.idx] <- 0
    if (!is.null(STEP1$Sigma.11)) { # maybe se = "none"...
      STEP1$Sigma.11 <- STEP1$Sigma.11[-both.idx, -both.idx]
    }
  }

  if (output == "list" && lavoptions$se == "none") {
    return(c(STEP1, STEP2))
  }

  ################################################################
  # Step 3: assemble results in a 'dummy' JOINT model for output #
  ################################################################
  if (lav_verbose()) {
    cat("Creating JOINT lavaan object ... ")
  }
  JOINT <- lav_sam_step3_joint(
    FIT = FIT, PT = STEP2$PT,
    sam.method = sam.method
  )
  # fill information from FIT.PA
  JOINT@Options$optim.method <- STEP2$FIT.PA@Options$optim.method
  JOINT@Model@estimator <- FIT@Options$estimator # could be DWLS!
  if (sam.method %in% c("local", "fsr", "cfsr")) {
    JOINT@optim <- STEP2$FIT.PA@optim
    JOINT@test <- STEP2$FIT.PA@test
  }
  # fill in vcov/se information from step 1
  if (!lavoptions$se %in% c("none", "bootstrap")) {
    JOINT@Options$se <- lavoptions$se # naive/twostep/none/local/bootstrap
    if (JOINT@Model@ceq.simple.only) {
      VCOV.ALL <- matrix(
        0, JOINT@Model@nx.unco,
        JOINT@Model@nx.unco
      )
    } else {
      VCOV.ALL <- matrix(
        0, JOINT@Model@nx.free,
        JOINT@Model@nx.free
      )
    }
    VCOV.ALL[STEP1$step1.free.idx, STEP1$step1.free.idx] <- STEP1$Sigma.11
    JOINT@vcov <- list(
      se = lavoptions$se,
      information = lavoptions$information[1],
      vcov = VCOV.ALL
    )
    # no need to fill @ParTable$se, as step1 SE values should already
    # be in place
  }

  if (lav_verbose()) {
    cat("done.\n")
  }

  ##############################################
  # Step 4: compute standard errors for step 2 #
  ##############################################

  if (lavoptions$se == "bootstrap") {
    if (lav_verbose()) {
      cat("computing VCOV for      se = bootstrap ...")
    }
    # construct temporary sam object, so that lav_bootstrap_internal() can
    # use it
    SAM <- lav_sam_table(
      JOINT = JOINT, STEP1 = STEP1,
      FIT.PA = STEP2$FIT.PA,
      cmd = cmd, lavoptions = FIT@Options,
      mm.args = mm.args,
      struc.args = struc.args,
      sam.method = sam.method,
      local.options = local.options,
      global.options = global.options
    )
    sam_object <- JOINT
    sam_object@internal <- SAM
    default.args <- list(R = 1000L, type = "ordinary",
                         show.progress = FALSE,
                         check.post = TRUE, keep.idx = FALSE)
    this.args <- modifyList(default.args, bootstrap)
    COEF <- lav_bootstrap_internal(object = sam_object,
      R = this.args$R, show.progress = this.args$show.progress,
      type = this.args$type, FUN = "coef",
      check.post = this.args$check.post, keep.idx = this.args$keep.idx)
    COEF.orig <- COEF
    error.idx <- attr(COEF, "error.idx")
    nfailed <- length(error.idx) # zero if NULL
    if (nfailed > 0L) {
      lav_msg_warn(gettextf(
        "%s bootstrap runs failed or did not converge.", nfailed))
    }
    notok <- length(attr(COEF, "nonadmissible")) # zero if NULL
    if (notok > 0L) {
      lav_msg_warn(gettextf(
        "%s bootstrap runs resulted in nonadmissible solutions.", notok))
    }
    if (length(error.idx) > 0L) {
      # new in 0.6-13: we must still remove them!
      COEF <- COEF[-error.idx, , drop = FALSE]
      # this also drops the attributes
    }
    nboot <- nrow(COEF)
    VarCov <- cov(COEF) * (nboot - 1) / nboot
    JOINT@boot$coef <- COEF.orig
    JOINT@Options$bootstrap <- this.args$R
    VCOV <- list(se = "bootstrap", VCOV = VarCov)

    if (lav_verbose()) {
      cat("done.\n")
    }

  # analytic twostep/standard/naive/local
  } else {
    VCOV <- lav_sam_step2_se(
      FIT = FIT, JOINT = JOINT, STEP1 = STEP1,
      STEP2 = STEP2, local.options = local.options
    )
  }

  # fill in twostep standard errors
  if (lavoptions$se != "none") {
    PT <- JOINT@ParTable
    JOINT@Options$se <- VCOV$se
    JOINT@vcov$se <- VCOV$se
    if (lavoptions$se == "bootstrap") {
      JOINT@vcov$vcov <- VCOV$VCOV
    } else {
      JOINT@vcov$vcov[STEP2$step2.free.idx, STEP2$step2.free.idx] <- VCOV$VCOV
    }
    PT$se <- lav_model_vcov_se(
      lavmodel = JOINT@Model,
      lavpartable = PT,
      VCOV = JOINT@vcov$vcov
    )
    JOINT@ParTable <- PT
  }



  ##################
  # Step 5: Output #
  ##################

  # assemble pieces to assemble final lavaan object
  if (output == "lavaan") {
    if (lav_verbose()) {
      cat("Assembling results for output ... ")
    }
    SAM <- lav_sam_table(
      JOINT = JOINT, STEP1 = STEP1,
      FIT.PA = STEP2$FIT.PA,
      cmd = cmd, lavoptions = FIT@Options,
      mm.args = mm.args,
      struc.args = struc.args,
      sam.method = sam.method,
      local.options = local.options,
      global.options = global.options
    )
    res <- JOINT
    res@internal <- SAM
    if (lav_verbose()) {
      cat("done.\n")
    }
  } else {
    res <- c(STEP1, STEP2, VCOV)
  }

  if (lav_verbose()) {
    cat("End of sam.\n")
  }

  res
}

# lav_partable_names
#
# YR. 29 june 2013
#  - as separate file; used to be in utils-user.R
#  - lav_partable_names (aka 'vnames') allows multiple options in 'type'
#    returning them all as a list (or just a vector if only 1 type is needed)

# public version
lav_object_vnames <- function(object, type = "ov", ...) { # nolint
  if (inherits(object, "lavaan") || inherits(object, "lavaanList")) {
    # check object
    object <- lav_object_check_version(object)
    partable <- object@ParTable
  } else if (inherits(object, "list") ||
    inherits(object, "data.frame")) {
    partable <- object
  } else if (inherits(object, "character")) {
    # just a model string?
    partable <- lavParseModelString(object)
  }
  lav_partable_vnames(partable, type = type, ...)
}
lavNames <- lav_object_vnames    # synonym #nolint

# return variable names in a partable
# - the 'type' argument determines the status of the variable: observed,
#   latent, endo/exo/...; default = "ov", but most used is type = "all"
#   LDW 30/1/24: there is no default and most used is a single type: "all" is
#                rarely used in other code
# - the 'group' argument either selects a single group (if group is an integer)
#   or returns a list per group
# - the 'level' argument either selects a single level (if level is an integer)
#   or returns a list per level
#   LDW 30/1/24: 'level' argument not explicitly tested !?
# - the 'block' argument either selects a single block (if block is an integer)
#   or returns a list per block
#   LDW 30/1/24: 'block' argument not explicitly tested !?
#   LDW 29/2/24: ov.order = "data" via attribute "ovda"
# - YR 11/02/25: add type = "lv.ho" for higher-order latent variables
lav_partable_vnames <- function(partable, type = NULL, ..., # nolint
                                force.warn = FALSE, ov.x.fatal = FALSE) {
  # This function derives the names of some types of variable (as specified
  # in type) from a 'partable'. The 'warn' parameter needs no explanation.
  # The ov.x.fatal parameter implies, when set to TRUE, that the function
  # issues a 'stop' when there are exogenious variables present in variance/
  # covariance or intercept formulas.
  # The call of this function can also contain extra parameters (...) which
  # have to be the name(s) of blockvariable(s) to be used to select names.
  # If more than 1 blockvariable given, all must be satisfied to select!
  # The 'partable' must be a list with minimum members lhs, op, rhs.
  # Other members of 'partable' used (if present): block, ustart, free, exo,
  #                                                user, efa, rv, 'blockname'
  # If the 'partable' contains an attribute vnames and the type is not "*",
  # the 'type' elements of this attribute are used.

  # ----- lav_partable_vnames ---- common ----------------------------------
  # sanity check
  stopifnot(is.list(partable), !missing(type))
  # this is a special fuunction where the default is to suppress warnings,
  # overwritten if parameter force.warn TRUE (used in lav_partable function)
  current.warn <- lav_warn()
  if (force.warn) {
    if (lav_warn(TRUE)) on.exit(lav_warn(current.warn))
  } else {
    if (lav_warn(FALSE)) on.exit(lav_warn(current.warn))
  }
  # check for empty table
  if (length(partable$lhs) == 0) {
    return(character(0L))
  }
  # dotdotdot
  dotdotdot <- list(...)
  type.list <- c(
    "ov", # observed variables (ov)
    "ov.x", # (pure) exogenous observed variables
    "ov.nox", # non-exogenous observed variables
    "ov.model", # modeled observed variables (joint vs cond)
    "ov.y", # (pure) endogenous variables (dependent only)
    "ov.num", # numeric observed variables
    "ov.ord", # ordinal observed variables
    "ov.ind",  # observed indicators of latent variables
    "ov.cind", # observed indicators of composites (new in 0.6-20)
    "ov.orphan", # lonely observed intercepts/variances
    "ov.interaction", # interaction terms (with colon)
    "ov.efa", # indicators involved in efa

    "th", # thresholds ordinal only
    "th.mean", # thresholds ordinal + numeric variables

    "lv", # latent variables
    "lv.regular", # latent variables (defined by =~ only)
    "lv.formative", # latent variables (defined by <~ only) (old style)
    "lv.composite", # latent variables (defined by <~ only) (new style)
    "lv.x", # (pure) exogenous variables
    "lv.y", # (pure) endogenous variables
    "lv.nox", # non-exogenous latent variables
    "lv.nonnormal", # latent variables with non-normal indicators
    "lv.interaction", # interaction terms
    "lv.efa", # latent variables involved in efa
    "lv.rv", # random slopes, random variables
    "lv.ind", # latent indicators (higher-order cfa)
    "lv.ho",  # higher-order latent variables
    "lv.marker", # marker indicator per lv

    "eqs.y", # y's in regression
    "eqs.x" # x's in regression
  )
  if (type[1L] != "all" && type[1L] != "*" && !all(type %in% type.list)) {
    wrongtypes <- type[!(type %in% type.list)]
    lav_msg_stop(sprintf(
      ngettext(length(wrongtypes),
      "type = %s is not a valid option",
      "type = %s are not valid options"),
      lav_msg_view(wrongtypes, "none", FALSE)))
  }
  return.value <- NULL
  if (type[1L] != "*" && !is.null(attr(partable, "vnames"))) {
    # ----- lav_partable_vnames ---- cached data --------------------------
    # uncomment/comment following line to enable/disable trace
    # lav_trace(paste("cached:", paste(type, collapse = ",")))

    if (type[1L] == "all") {
      return.value <- attr(partable, "vnames")
    } else {
      return.value <- attr(partable, "vnames")[type]
    }
  }
  # ----- lav_partable_vnames ---- common ----------------------------------
  if (type[1L] == "all" || type[1L] == "*") {
    type <- type.list
  }
  # ALWAYS need `block' column -- create one if missing
  if (is.null(partable$block)) {
    partable$block <- rep(1L, length(partable$lhs))
  }
  # per default, use full partable
  block.select <- lav_partable_block_values(partable)
  # check for ... selection argument(s)
  ndotdotdot <- length(dotdotdot)
  if (ndotdotdot > 0L) {
    dot.names <- names(dotdotdot)
    row.select <- rep(TRUE, length(partable$lhs))
    for (dot in seq_len(ndotdotdot)) {
      # selection variable?
      block.var <- dot.names[dot]
      block.val <- dotdotdot[[block.var]]
      # do we have this 'block.var' in partable?
      if (is.null(partable[[block.var]])) {
        # for historical reasons, treat "group = 1" special
        if (block.var == "group" && block.val == 1L) {
          partable$group <- rep(1L, length(partable$lhs))
          # remove block == 0
          idx <- which(partable$block == 0L)
          if (length(idx) > 0L) {
            partable$group[idx] <- 0L
          }
          row.select <- (row.select &
            partable[[block.var]] %in% block.val)
        } else {
          lav_msg_stop(gettextf(
            "selection variable '%s' not found in the parameter table.",
            block.var))
        }
      } else {
        if (!all(block.val %in% partable[[block.var]])) {
          lav_msg_stop(gettextf(
            "%1$s column does not contain value `%2$s'", block.var, block.val))
        }
        row.select <- (row.select &
          !partable$op %in% c("==", "<", ">", ":=") &
          partable[[block.var]] %in% block.val)
      }
    } # dot
    block.select <- unique(partable$block[row.select])
    if (length(block.select) == 0L) {
      lav_msg_warn(gettext("no blocks selected."))
    }
  }
  if (is.null(return.value)) {
    # ----- lav_partable_vnames ---- no cache ------------------------

    # uncomment/comment following line to enable/disable trace
    # lav_trace(paste("computed:", paste(type, collapse = ",")))

    # random slope names, if any (new in 0.6-7)
    if (!is.null(partable$rv) && any(nchar(partable$rv) > 0L)) {
      rv.names <- unique(partable$rv[nchar(partable$rv) > 0L])
    } else {
      rv.names <- character(0L)
    }

    # output: list per block
    return.value <- lapply(type, function(x) {
      vector("list", length = length(block.select))
    })
    names(return.value) <- type

    for (b in block.select) {
      # indices for this block
      block.ind <- partable$block == b

      # always compute lv.names
      lv.names <- unique(partable$lhs[block.ind &
        (partable$op == "=~" | partable$op == "<~")])
      # including random slope names
      lv.names2 <- unique(c(lv.names, rv.names))

      # determine lv interactions
      int.names <- unique(partable$rhs[block.ind &
        grepl(":", partable$rhs, fixed = TRUE)])
      n.int <- length(int.names)
      if (n.int > 0L) {
        ok.idx <- logical(n.int)
        for (iv in seq_len(n.int)) {
          tmp.names <- strsplit(int.names[iv], ":", fixed = TRUE)[[1L]]
          # three scenario's:
          # - both variables are latent (ok)
          # - both variables are observed (ignore)
          # - only one latent (warn??) -> upgrade observed to latent
          # thus if at least one is in lv.names, we treat it as a
          # latent interaction
          if (any(tmp.names %in% lv.names)) {
            ok.idx[iv] <- TRUE
          }
        }
        lv.interaction <- int.names[ok.idx]
        lv.names <- c(lv.names, lv.interaction)
        lv.names2 <- c(lv.names2, lv.interaction)
      } else {
        lv.interaction <- character(0L)
      }
      if (length(type) == 1L) {
        # ----- lav_partable_vnames ---- no cache ----- 1 type -----------
        # store lv
        if ("lv" == type) {
          # check if FLAT for random slopes
          # if (!is.null(partable$rv) && any(nchar(partable$rv) > 0L) &&
          #    !is.null(partable$block)) {
          #    return.value$lv[[b]] <- lv.names2
          # } else {
          # here, they will be 'defined' at level 2 as regular =~ lvs
          return.value$lv[[b]] <- lv.names
          # }
          next
        }

        # regular latent variables ONLY (ie defined by =~ only)
        if ("lv.regular" == type) {
          out <- unique(partable$lhs[block.ind &
            partable$op == "=~" &
            partable$lhs != partable$rhs & # no phantom
            !partable$lhs %in% rv.names])
          return.value$lv.regular[[b]] <- out
          next
        }

        # interaction terms involving latent variables (only)
        if ("lv.interaction" == type) {
          return.value$lv.interaction[[b]] <- lv.interaction
          next
        }

        # formative latent variables: phantom lv + zero residual
        if ("lv.formative" == type) {
          out <- unique(partable$lhs[block.ind &
            partable$lhs == partable$rhs &
            partable$op == "=~"])
          rm.idx <- integer(0L)
          for (i in seq_len(length(out))) {
            var.idx <- which(block.ind &
                             partable$op == "~~" &
                             partable$lhs == out[i] &
                             partable$lhs == partable$rhs)
            if (length(var.idx) == 0L) {
              next
            }
            if (!is.null(partable$mod.idx) && !is.null(partable$fixed)) {
              if (partable$fixed[var.idx] != "0") {
                rm.idx <- c(rm.idx, i)
              }
            } else if (!is.null(partable$free) && !is.null(partable$ustart)) {
              if (partable$free[var.idx] > 0L ||
                  partable$ustart[var.idx] != 0) {
                rm.idx <- c(rm.idx, i)
              }
            }
          }
          if (length(rm.idx) > 0L) {
            out <- out[-rm.idx]
          }
          return.value$lv.formative[[b]] <- out
          next
        }

        # composites defined by "<~"
        if ("lv.composite" == type) {
          out <- unique(partable$lhs[block.ind &
            partable$op == "<~"])
          return.value$lv.composite[[b]] <- out
          next
        }

        # lv's involved in efa
        if (any(type == c("lv.efa", "ov.efa"))) {
          if (is.null(partable$efa)) {
            out <- character(0L)
          } else {
            set.names <- lav_partable_efa_values(partable)
            out <- unique(partable$lhs[partable$op == "=~" &
              block.ind &
              partable$efa %in% set.names])
          }
          if (type == "ov.efa") ov_efa <- out
          if (type == "lv.efa") {
            return.value$lv.efa[[b]] <- out
            next
          }
        }

        # lv's that are random slopes
        if ("lv.rv" == type) {
          if (is.null(partable$rv)) {
            out <- character(0L)
          } else {
            out <- unique(partable$lhs[partable$op == "=~" &
              block.ind &
              partable$lhs %in% rv.names])
          }
          return.value$lv.rv[[b]] <- out
          next
        }

        # lv's that are indicators of a higher-order factor
        if ("lv.ind" == type) {
          out <- unique(partable$rhs[block.ind &
            partable$op == "=~" &
            partable$rhs %in% lv.names &
            partable$lhs != partable$rhs]) # no phantom lv's
          return.value$lv.ind[[b]] <- out
          next
        }

        # higher-order latent variables
        if ("lv.ho" == type) {
          out.ind <- unique(partable$rhs[block.ind &
            partable$op == "=~" &
            partable$rhs %in% lv.names &
            partable$lhs != partable$rhs]) # no phantom lv's
          out <- unique(partable$lhs[block.ind &
            partable$op == "=~" &
            partable$lhs %in% lv.names &
            partable$rhs %in% out.ind])
          return.value$lv.ho[[b]] <- out
          next
        }

        # eqs.y
        if (!(any(type == c("lv", "lv.regular")))) {
          eqs.y <- unique(partable$lhs[block.ind &
            partable$op == "~"])
        }

        # store eqs.y
        if ("eqs.y" == type) {
          return.value$eqs.y[[b]] <- eqs.y
          next
        }

        # eqs.x
        if (!(any(type == c("lv", "lv.regular", "lv.x")))) {
          eqs.x <- unique(partable$rhs[block.ind &
            (partable$op == "~" |
              partable$op == "<~")])
        }

        # store eqs.x
        if ("eqs.x" == type) {
          return.value$eqs.x[[b]] <- eqs.x
          next
        }

        # v.ind -- indicators of latent variables
        if (!(any(type == c("lv", "lv.regular")))) {
          v.ind <- unique(partable$rhs[block.ind &
            partable$op == "=~"])
        }

        # v.cind -- indicators of composites
        if (!(any(type == c("lv", "lv.regular")))) {
          v.cind <- unique(partable$rhs[block.ind &
            partable$op == "<~"])
        }

        # ov.*
        if (!(any(type == c("lv", "lv.regular", "lv.x", "lv.y")))) {
          # 1. indicators, which are not latent variables themselves
          ov.ind <- v.ind[!v.ind %in% lv.names2]
          # 1b. indicator of composites
          ov.cind <- v.cind[!v.cind %in% lv.names2]
          # 2. dependent ov's
          ov.y <- eqs.y[!eqs.y %in% c(lv.names2, ov.ind, ov.cind)]
          # 3. independent ov's
          if (lav_partable_nlevels(partable) > 1L && b > 1L) {
            # NEW in 0.6-8: if an 'x' was an 'y' in a previous level,
            #               treat it as 'y'
            tmp.eqs.y <- unique(partable$lhs[partable$op == "~"]) # all blocks
            ov.x <- eqs.x[!eqs.x %in% c(lv.names2, ov.ind, ov.cind, tmp.eqs.y)]
          } else {
            ov.x <- eqs.x[!eqs.x %in% c(lv.names2, ov.ind, ov.cind, ov.y)]
          }
          # new in 0.6-12: if we have interaction terms in ov.x, check
          # if some terms are in eqs.y; if so, remove the interaction term
          # from ov.x
          int.idx <- which(grepl(":", ov.x, fixed = TRUE))
          bad.idx <- integer(0L)
          for (iv in int.idx) {
            tmp.names <- strsplit(ov.x[iv], ":", fixed = TRUE)[[1L]]
            if (any(tmp.names %in% eqs.y)) {
              bad.idx <- c(bad.idx, iv)
            }
          }
          if (length(bad.idx) > 0L) {
            ov.y <- unique(c(ov.y, ov.x[bad.idx]))
            # it may be removed later, but needed to construct ov.names
            ov.x <- ov.x[-bad.idx]
          }
        }

        # observed variables
        # easy approach would be: everything that is not in lv.names,
        # but the main purpose here is to 'order' the observed variables
        # according to 'type' (indicators, ov.y, ov.x, orphans)
        if (!(any(type == c("lv", "lv.regular", "lv.x", "lv.y")))) {
          # 4. orphaned covariances
          ov.cov <- c(
            partable$lhs[block.ind &
              partable$op == "~~" &
              !partable$lhs %in% lv.names2],
            partable$rhs[block.ind &
              partable$op == "~~" &
              !partable$rhs %in% lv.names2]
          )
          # 5. orphaned intercepts/thresholds
          ov.int <- partable$lhs[block.ind &
            (partable$op == "~1" |
              partable$op == "|") &
            !partable$lhs %in% lv.names2]

          ov.tmp <- c(ov.ind, ov.cind, ov.y, ov.x)
          ov.extra <- unique(c(ov.cov, ov.int)) # must be in this order!
          # so that
          # lav_partable_independence
          # retains the same order
          ov.names <- c(ov.tmp, ov.extra[!ov.extra %in% ov.tmp])
        }

        # store ov?
        if ("ov" == type) {
          return.value$ov[[b]] <- ov.names
          next
        }

        if ("ov.ind" == type) {
          return.value$ov.ind[[b]] <- ov.ind
          next
        }

        if ("ov.cind" == type) {
          return.value$ov.cind[[b]] <- ov.cind
          next
        }

        if ("ov.interaction" == type) {
          ov.int.names <- ov.names[grepl(":", ov.names, fixed = TRUE)]
          n.int <- length(ov.int.names)
          if (n.int > 0L) {
            ov.names.noint <- ov.names[!ov.names %in% ov.int.names]

            ok.idx <- logical(n.int)
            for (iv in seq_len(n.int)) {
              tmp.names <- strsplit(ov.int.names[iv], ":", fixed = TRUE)[[1L]]

              # two scenario's:
              # - both variables are in ov.names.noint (ok)
              # - at least one variables is NOT in ov.names.noint (ignore)
              if (all(tmp.names %in% ov.names.noint)) {
                ok.idx[iv] <- TRUE
              }
            }
            ov.interaction <- ov.int.names[ok.idx]
          } else {
            ov.interaction <- character(0L)
          }

          return.value$ov.interaction[[b]] <- ov.interaction
          next
        }

        if ("ov.efa" == type) {
          ov.efa <- partable$rhs[partable$op == "=~" &
            block.ind &
            partable$rhs %in% ov.ind &
            partable$lhs %in% ov_efa]
          return.value$ov.efa[[b]] <- unique(ov.efa)
          next
        }


        # exogenous `x' covariates
        if (any(type == c(
          "ov.x", "ov.nox", "ov.model",
          "th.mean", "lv.nonnormal"
        ))) {
          # correction: is any of these ov.names.x mentioned as a variance,
          #             covariance, or intercept?
          # this should trigger a warning in lav_model_partable()
          if (is.null(partable$user)) { # FLAT!
            partable$user <- rep(1L, length(partable$lhs))
          }
          vars <- c(
            partable$lhs[block.ind &
              partable$op == "~1" &
              partable$user == 1],
            partable$lhs[block.ind &
              partable$op == "~~" &
              partable$user == 1],
            partable$rhs[block.ind &
              partable$op == "~~" &
              partable$user == 1]
          )
          idx.no.x <- which(ov.x %in% vars)
          if (length(idx.no.x)) {
            if (ov.x.fatal) {
              lav_msg_stop(gettextf(
                "model syntax contains variance/covariance/intercept formulas
                involving (an) exogenous variable(s): [%s];  Please remove them
                and try again.", lav_msg_view(ov.x[idx.no.x], "none")))
            }
            lav_msg_warn(gettextf(
                "model syntax contains variance/covariance/intercept formulas
                involving (an) exogenous variable(s): [%s]; these variables will
                now be treated as random introducing additional free parameters.
                If you wish to treat those variables as fixed, remove these
                formulas from the model syntax. Otherwise, consider adding the
                fixed.x = FALSE option.", lav_msg_view(ov.x[idx.no.x], "none")))
            ov.x <- ov.x[-idx.no.x]
          }
          ov.tmp.x <- ov.x

          # extra
          if (!is.null(partable$exo)) {
            ov.cov <- c(
              partable$lhs[block.ind &
                partable$op == "~~" &
                partable$exo == 1L],
              partable$rhs[block.ind &
                partable$op == "~~" &
                partable$exo == 1L]
            )
            ov.int <- partable$lhs[block.ind &
              partable$op == "~1" &
              partable$exo == 1L]
            ov.extra <- unique(c(ov.cov, ov.int))
            ov.tmp.x <- c(ov.tmp.x, ov.extra[!ov.extra %in% ov.tmp.x])
          }

          ov.names.x <- ov.tmp.x
        }

        # store ov.x?
        if ("ov.x" == type) {
          return.value$ov.x[[b]] <- ov.names.x
          next
        }

        # story ov.orphan?
        if ("ov.orphan" == type) {
          return.value$ov.orphan[[b]] <- ov.extra
          next
        }

        # ov's withouth ov.x
        if (any(type == c(
          "ov.nox", "ov.model",
          "th.mean", "lv.nonnormal"
        ))) {
          ov.names.nox <- ov.names[!ov.names %in% ov.names.x]
        }

        # store ov.nox
        if ("ov.nox" == type) {
          return.value$ov.nox[[b]] <- ov.names.nox
          next
        }

        # store ov.model
        if ("ov.model" == type) {
          # if no conditional.x, this is just ov
          # else, this is ov.nox
          if (any(block.ind & partable$op == "~" &
            partable$exo == 1L)) {
            return.value$ov.model[[b]] <- ov.names.nox
          } else {
            return.value$ov.model[[b]] <- ov.names
          }
          next
        }

        # ov's strictly ordered
        if (any(type == c(
          "ov.ord", "th", "th.mean",
          "ov.num", "lv.nonnormal"
        ))) {
          tmp <- unique(partable$lhs[block.ind &
            partable$op == "|"])
          ord.names <- ov.names[ov.names %in% tmp]
        }

        if ("ov.ord" == type) {
          return.value$ov.ord[[b]] <- ord.names
          next
        }

        # ov's strictly numeric
        if (any(type == c("ov.num", "lv.nonnormal"))) {
          ov.num <- ov.names[!ov.names %in% ord.names]
        }

        if ("ov.num" == type) {
          return.value$ov.num[[b]] <- ov.num
          next
        }

        # nonnormal lv's
        if ("lv.nonnormal" == type) {
          # regular lv's
          lv.reg <- unique(partable$lhs[block.ind &
                           partable$op == "=~" &
                           partable$lhs != partable$rhs])
          if (length(lv.reg) > 0L) {
            out <- unlist(lapply(lv.reg, function(x) {
              # get indicators for this lv
              tmp.ind <- unique(partable$rhs[block.ind &
                partable$op == "=~" &
                partable$lhs == x])
              if (!all(tmp.ind %in% ov.num)) {
                return(x)
              } else {
                return(character(0))
              }
            }), use.names = FALSE)
            return.value$lv.nonnormal[[b]] <- out
          } else {
            return.value$lv.nonnormal[[b]] <- character(0)
          }
          next
        }

        if (any(c("th", "th.mean") == type)) {
          tmp.th.lhs <- partable$lhs[block.ind &
            partable$op == "|"]
          tmp.th.rhs <- partable$rhs[block.ind &
            partable$op == "|"]
        }

        # threshold
        if ("th" == type) {
          if (length(ord.names) > 0L) {
            # return in the right order (following ord.names!)
            out <- unlist(lapply(ord.names, function(x) {
              idx <- which(x == tmp.th.lhs)
              tmp.th <- unique(paste(tmp.th.lhs[idx], "|",
                tmp.th.rhs[idx],
                sep = ""
              ))
              # make sure the th's are in increasing order
              # sort(tmp.th)
              # NO!, don't do that; t10 will be before t2
              # fixed in 0.6-1 (bug report from Myrsini)
              # in 0.6-12, we do this anyway like this:

              # get var name
              tmp.th1 <- sapply(
                strsplit(tmp.th, split = "\\|t"),
                "[[", 1
              )
              # get number, and sort
              tmp.th2 <- as.character(sort(as.integer(sapply(
                strsplit(tmp.th, split = "\\|t"), "[[", 2
              ))))
              # paste back togehter in the right order
              paste(tmp.th1, tmp.th2, sep = "|t")
            }), use.names = FALSE)
          } else {
            out <- character(0L)
          }
          return.value$th[[b]] <- out
          next
        }

        # thresholds and mean/intercepts of numeric variables
        if ("th.mean" == type) {
          # if fixed.x -> use ov.names.nox
          # else -> use ov.names
          if (is.null(partable$exo) || all(partable$exo == 0L)) {
            tmp.ov.names <- ov.names
          } else {
            tmp.ov.names <- ov.names.nox
          }
          if (length(tmp.ov.names) > 0L) {
            # return in the right order (following ov.names.nox!)
            out <- unlist(lapply(tmp.ov.names, function(x) {
              if (x %in% ord.names) {
                idx <- which(x == tmp.th.lhs)
                tmp.th <- unique(
                  paste(tmp.th.lhs[idx], "|",
                    tmp.th.rhs[idx],
                    sep = ""
                  ),
                  use.names = FALSE
                )
                # make sure the th's are in increasing order
                # get var name
                tmp.th1 <- sapply(
                  strsplit(tmp.th, split = "\\|t"),
                  "[[", 1
                )
                # get number, and sort
                tmp.th2 <- as.character(sort(as.integer(sapply(
                  strsplit(tmp.th, split = "\\|t"), "[[", 2
                ))))
                # paste back togehter in the right order
                paste(tmp.th1, tmp.th2, sep = "|t")
              } else {
                x
              }
            }))
          } else {
            out <- character(0L)
          }
          return.value$th.mean[[b]] <- out
          next
        }

        # exogenous lv's
        if (any(c("lv.x", "lv.nox") == type)) {
          tmp <- lv.names[!lv.names %in% c(v.ind, eqs.y)]
          lv.names.x <- lv.names[lv.names %in% tmp]
        }

        if ("lv.x" == type) {
          return.value$lv.x[[b]] <- lv.names.x
          next
        }

        # dependent ov (but not also indicator or x)
        if ("ov.y" == type) {
          tmp <- eqs.y[!eqs.y %in% c(v.ind, eqs.x, lv.names)]
          return.value$ov.y[[b]] <- ov.names[ov.names %in% tmp]
          next
        }

        # dependent lv (but not also indicator or x)
        if ("lv.y" == type) {
          tmp <- eqs.y[!eqs.y %in% c(v.ind, eqs.x) &
            eqs.y %in% lv.names]
          return.value$lv.y[[b]] <- lv.names[lv.names %in% tmp]
          next
        }

        # non-exogenous latent variables
        if ("lv.nox" == type) {
          return.value$lv.nox[[b]] <- lv.names[!lv.names %in% lv.names.x]
          next
        }

        # marker indicator (if any) for each lv
        if ("lv.marker" == type) {
          # default: "" per lv
          out <- character(length(lv.names))
          names(out) <- lv.names
          for (l in seq_len(length(lv.names))) {
            this.lv.name <- lv.names[l]
            # try to see if we can find a 'marker' indicator for this factor
            # here defined as: has fixed-to-one factor loading
            marker.idx <- which(block.ind &
              partable$op == "=~" &
              partable$lhs == this.lv.name &
              partable$rhs %in% v.ind &
              partable$ustart == 1L &
              partable$free == 0L)
            if (length(marker.idx) > 0L) {
              # we may have multiple potential markers
              potential.markers <- partable$rhs[marker.idx]
              valid.markers <- character(0L)
              for (m in seq_along(potential.markers)) {
                this.marker.idx <- marker.idx[m]
                # check if 'other' loadings are fixed to zero
                other.idx <- which(block.ind &
                  partable$op == "=~" &
                  partable$lhs != this.lv.name &
                  partable$rhs == partable$rhs[this.marker.idx] &
                  partable$free == 0L)
                if (length(other.idx) == 0L) {
                  # simple structure, or one factor
                  valid.markers <- c(valid.markers,
                                     partable$rhs[this.marker.idx])
                } else if (all(partable$ustart[other.idx] == 0)) {
                  valid.markers <- c(valid.markers,
                                     partable$rhs[this.marker.idx])
                }
              }
              if (length(valid.markers) > 0L) {
                out[l] <- valid.markers[1L] # pick the first one
              }
            }
          } # l
          return.value$lv.marker[[b]] <- out
        }
      } else {
        # ----- lav_partable_vnames ---- no cache ----- more than 1 type ------
        # store lv
        if (any("lv" == type)) {
          # check if FLAT for random slopes
          # if (!is.null(partable$rv) && any(nchar(partable$rv) > 0L) &&
          #    !is.null(partable$block)) {
          #    return.value$lv[[b]] <- lv.names2
          # } else {
          # here, they will be 'defined' at level 2 as regular =~ lvs
          return.value$lv[[b]] <- lv.names
          # }
        }

        # regular latent variables ONLY (ie defined by =~ only)
        if (any("lv.regular" == type)) {
          out <- unique(partable$lhs[block.ind &
            partable$op == "=~" &
            partable$lhs != partable$rhs & # no phantom
            !partable$lhs %in% rv.names])
          return.value$lv.regular[[b]] <- out
        }


        # interaction terms involving latent variables (only)
        if (any("lv.interaction" == type)) {
          return.value$lv.interaction[[b]] <- lv.interaction
        }

        # formative latent variables: phantom lv + zero residual
        if (any("lv.formative" == type)) {
          out <- unique(partable$lhs[block.ind &
            partable$lhs == partable$rhs &
            partable$op == "=~"])
          rm.idx <- integer(0L)
          for (i in seq_len(length(out))) {
            var.idx <- which(block.ind &
                             partable$op == "~~" &
                             partable$lhs == out[i] &
                             partable$lhs == partable$rhs)
            if (length(var.idx) == 0L) {
              next
            }
            if (!is.null(partable$mod.idx) && !is.null(partable$fixed)) {
              if (partable$fixed[var.idx] != "0") {
                rm.idx <- c(rm.idx, i)
              }
            } else if (!is.null(partable$free) && !is.null(partable$ustart)) {
              if (partable$free[var.idx] > 0L ||
                  partable$ustart[var.idx] != 0) {
                rm.idx <- c(rm.idx, i)
              }
            }
          }
          if (length(rm.idx) > 0L) {
            out <- out[-rm.idx]
          }
          return.value$lv.formative[[b]] <- out
        }

        # composite latent variables (ie defined by <~)
        if (any("lv.composite" == type)) {
          out <- unique(partable$lhs[block.ind &
            partable$op == "<~"])
          return.value$lv.composite[[b]] <- out
        }

        # lv's involved in efa
        if (any(type %in% c("lv.efa", "ov.efa"))) {
          if (is.null(partable$efa)) {
            out <- character(0L)
          } else {
            set.names <- lav_partable_efa_values(partable)
            out <- unique(partable$lhs[partable$op == "=~" &
              block.ind &
              partable$efa %in% set.names])
          }
          if (any(type == "ov.efa")) ov_efa <- out
          if (any(type == "lv.efa")) return.value$lv.efa[[b]] <- out
        }

        # lv's that are random slopes
        if (any("lv.rv" == type)) {
          if (is.null(partable$rv)) {
            out <- character(0L)
          } else {
            out <- unique(partable$lhs[partable$op == "=~" &
              block.ind &
              partable$lhs %in% rv.names])
          }
          return.value$lv.rv[[b]] <- out
        }

        # lv's that are indicators of a higher-order factor
        if (any("lv.ind" == type)) {
          out <- unique(partable$rhs[block.ind &
            partable$op == "=~" &
            partable$rhs %in% lv.names &
            partable$lhs != partable$rhs]) # no phantom lv's
          return.value$lv.ind[[b]] <- out
        }

        # higher-order latent variables
        if (any("lv.ho" == type)) {
          out.ind <- unique(partable$rhs[block.ind &
            partable$op == "=~" &
            partable$rhs %in% lv.names &
            partable$lhs != partable$rhs]) # no phantom lv's
          out <- unique(partable$lhs[block.ind &
            partable$op == "=~" &
            partable$lhs %in% lv.names &
            partable$rhs %in% out.ind])
          return.value$lv.ho[[b]] <- out
        }

        # eqs.y
        eqs.y <- unique(partable$lhs[block.ind &
          partable$op == "~"])

        # store eqs.y
        if (any("eqs.y" == type)) {
          return.value$eqs.y[[b]] <- eqs.y
        }

        # eqs.x
        eqs.x <- unique(partable$rhs[block.ind &
          (partable$op == "~" |
            partable$op == "<~")])

        # store eqs.x
        if (any("eqs.x" == type)) {
          return.value$eqs.x[[b]] <- eqs.x
        }

        # v.ind -- indicators of latent variables
        v.ind <- unique(partable$rhs[block.ind &
          partable$op == "=~"])

        # v.cind -- indicators of composites
        v.cind <- unique(partable$rhs[block.ind &
          partable$op == "<~"])


        # ov.*
        # 1. indicators, which are not latent variables themselves
        ov.ind <- v.ind[!v.ind %in% lv.names2]
        # 1a. indicators of composites
        ov.cind <- v.cind[!v.cind %in% lv.names2]
        # 2. dependent ov's
        ov.y <- eqs.y[!eqs.y %in% c(lv.names2, ov.ind, ov.cind)]
        # 3. independent ov's
        if (lav_partable_nlevels(partable) > 1L && b > 1L) {
          # NEW in 0.6-8: if an 'x' was an 'y' in a previous level,
          #               treat it as 'y'
          tmp.eqs.y <- unique(partable$lhs[partable$op == "~"]) # all blocks
          ov.x <- eqs.x[!eqs.x %in% c(lv.names2, ov.ind, ov.cind, tmp.eqs.y)]
        } else {
          ov.x <- eqs.x[!eqs.x %in% c(lv.names2, ov.ind, ov.cind, ov.y)]
        }
        # new in 0.6-12: if we have interaction terms in ov.x, check
        # if some terms are in eqs.y; if so, remove the interaction term
        # from ov.x
        int.idx <- which(grepl(":", ov.x, fixed = TRUE))
        bad.idx <- integer(0L)
        for (iv in int.idx) {
          tmp.names <- strsplit(ov.x[iv], ":", fixed = TRUE)[[1L]]
          if (any(tmp.names %in% eqs.y)) {
            bad.idx <- c(bad.idx, iv)
          }
        }
        if (length(bad.idx) > 0L) {
          ov.y <- unique(c(ov.y, ov.x[bad.idx]))
          # it may be removed later, but needed to construct ov.names
          ov.x <- ov.x[-bad.idx]
        }

        # observed variables
        # easy approach would be: everything that is not in lv.names,
        # but the main purpose here is to 'order' the observed variables
        # according to 'type' (indicators, ov.y, ov.x, orphans)

        # 4. orphaned covariances
        ov.cov <- c(
          partable$lhs[block.ind &
            partable$op == "~~" &
            !partable$lhs %in% lv.names2],
          partable$rhs[block.ind &
            partable$op == "~~" &
            !partable$rhs %in% lv.names2]
        )
        # 5. orphaned intercepts/thresholds
        ov.int <- partable$lhs[block.ind &
          (partable$op == "~1" |
            partable$op == "|") &
          !partable$lhs %in% lv.names2]

        ov.tmp <- c(ov.ind, ov.cind, ov.y, ov.x)
        ov.extra <- unique(c(ov.cov, ov.int)) # must be in this order!
        # so that
        # lav_partable_independence
        # retains the same order
        ov.names <- c(ov.tmp, ov.extra[!ov.extra %in% ov.tmp])

        # store ov?
        if (any("ov" == type)) {
          return.value$ov[[b]] <- ov.names
        }

        if (any("ov.ind" == type)) {
          return.value$ov.ind[[b]] <- ov.ind
        }

        if (any("ov.cind" == type)) {
          return.value$ov.cind[[b]] <- ov.cind
        }

        if (any("ov.interaction" == type)) {
          ov.int.names <- ov.names[grepl(":", ov.names, fixed = TRUE)]
          n.int <- length(ov.int.names)
          if (n.int > 0L) {
            ov.names.noint <- ov.names[!ov.names %in% ov.int.names]

            ok.idx <- logical(n.int)
            for (iv in seq_len(n.int)) {
              tmp.names <- strsplit(ov.int.names[iv], ":", fixed = TRUE)[[1L]]

              # two scenario's:
              # - both variables are in ov.names.noint (ok)
              # - at least one variables is NOT in ov.names.noint (ignore)
              if (all(tmp.names %in% ov.names.noint)) {
                ok.idx[iv] <- TRUE
              }
            }
            ov.interaction <- ov.int.names[ok.idx]
          } else {
            ov.interaction <- character(0L)
          }

          return.value$ov.interaction[[b]] <- ov.interaction
        }

        if (any("ov.efa" == type)) {
          ov.efa <- partable$rhs[partable$op == "=~" &
            block.ind &
            partable$rhs %in% ov.ind &
            partable$lhs %in% ov_efa]
          return.value$ov.efa[[b]] <- unique(ov.efa)
        }


        # exogenous `x' covariates
        if (any(type %in% c(
          "ov.x", "ov.nox", "ov.model",
          "th.mean", "lv.nonnormal"
        ))) {
          # correction: is any of these ov.names.x mentioned as a variance,
          #             covariance, or intercept?
          # this should trigger a warning in lav_model_partable()
          if (is.null(partable$user)) { # FLAT!
            partable$user <- rep(1L, length(partable$lhs))
          }
          vars <- c(
            partable$lhs[block.ind &
              partable$op == "~1" &
              partable$user == 1],
            partable$lhs[block.ind &
              partable$op == "~~" &
              partable$user == 1],
            partable$rhs[block.ind &
              partable$op == "~~" &
              partable$user == 1]
          )
          idx.no.x <- which(ov.x %in% vars)
          if (length(idx.no.x)) {
            if (ov.x.fatal) {
              lav_msg_stop(gettextf(
                "model syntax contains variance/covariance/intercept formulas
                involving (an) exogenous variable(s): [%s];  Please remove them
                and try again.", lav_msg_view(ov.x[idx.no.x], "none")))
            }
              lav_msg_warn(gettextf(
                "model syntax contains variance/covariance/intercept formulas
                involving (an) exogenous variable(s): [%s]; these variables will
                now be treated as random introducing additional free parameters.
                If you wish to treat those variables as fixed, remove these
                formulas from the model syntax. Otherwise, consider adding the
                fixed.x = FALSE option.", lav_msg_view(ov.x[idx.no.x], "none")))
            ov.x <- ov.x[-idx.no.x]
          }
          ov.tmp.x <- ov.x

          # extra
          if (!is.null(partable$exo)) {
            ov.cov <- c(
              partable$lhs[block.ind &
                partable$op == "~~" &
                partable$exo == 1L],
              partable$rhs[block.ind &
                partable$op == "~~" &
                partable$exo == 1L]
            )
            ov.int <- partable$lhs[block.ind &
              partable$op == "~1" &
              partable$exo == 1L]
            ov.extra <- unique(c(ov.cov, ov.int))
            ov.tmp.x <- c(ov.tmp.x, ov.extra[!ov.extra %in% ov.tmp.x])
          }

          ov.names.x <- ov.tmp.x
        }

        # store ov.x?
        if (any("ov.x" == type)) {
          return.value$ov.x[[b]] <- ov.names.x
        }

        # story ov.orphan?
        if (any("ov.orphan" == type)) {
          return.value$ov.orphan[[b]] <- ov.extra
        }

        # ov's withouth ov.x
        if (any(type %in% c(
          "ov.nox", "ov.model",
          "th.mean", "lv.nonnormal"
        ))) {
          ov.names.nox <- ov.names[!ov.names %in% ov.names.x]
        }

        # store ov.nox
        if (any("ov.nox" == type)) {
          return.value$ov.nox[[b]] <- ov.names.nox
        }

        # store ov.model
        if (any("ov.model" == type)) {
          # if no conditional.x, this is just ov
          # else, this is ov.nox
          if (any(block.ind & partable$op == "~" &
            partable$exo == 1L)) {
            return.value$ov.model[[b]] <- ov.names.nox
          } else {
            return.value$ov.model[[b]] <- ov.names
          }
        }

        # ov's strictly ordered
        if (any(type %in% c(
          "ov.ord", "th", "th.mean",
          "ov.num", "lv.nonnormal"
        ))) {
          tmp <- unique(partable$lhs[block.ind &
            partable$op == "|"])
          ord.names <- ov.names[ov.names %in% tmp]
        }

        if (any("ov.ord" == type)) {
          return.value$ov.ord[[b]] <- ord.names
        }

        # ov's strictly numeric
        if (any(type %in% c("ov.num", "lv.nonnormal"))) {
          ov.num <- ov.names[!ov.names %in% ord.names]
        }

        if (any("ov.num" == type)) {
          return.value$ov.num[[b]] <- ov.num
        }

        # nonnormal lv's
        if (any("lv.nonnormal" == type)) {
          # regular lv's
          lv.reg <- unique(partable$lhs[block.ind &
                           partable$op == "=~" &
                           partable$lhs != partable$rhs])
          if (length(lv.reg) > 0L) {
            out <- unlist(lapply(lv.reg, function(x) {
              # get indicators for this lv
              tmp.ind <- unique(partable$rhs[block.ind &
                partable$op == "=~" &
                partable$lhs == x])
              if (!all(tmp.ind %in% ov.num)) {
                return(x)
              } else {
                return(character(0))
              }
            }), use.names = FALSE)
            return.value$lv.nonnormal[[b]] <- out
          } else {
            return.value$lv.nonnormal[[b]] <- character(0)
          }
        }

        if (any(c("th", "th.mean") %in% type)) {
          tmp.th.lhs <- partable$lhs[block.ind &
            partable$op == "|"]
          tmp.th.rhs <- partable$rhs[block.ind &
            partable$op == "|"]
        }

        # threshold
        if (any("th" == type)) {
          if (length(ord.names) > 0L) {
            # return in the right order (following ord.names!)
            out <- unlist(lapply(ord.names, function(x) {
              idx <- which(x == tmp.th.lhs)
              tmp.th <- unique(paste(tmp.th.lhs[idx], "|",
                tmp.th.rhs[idx],
                sep = ""
              ))
              # make sure the th's are in increasing order
              # sort(tmp.th)
              # NO!, don't do that; t10 will be before t2
              # fixed in 0.6-1 (bug report from Myrsini)
              # in 0.6-12, we do this anyway like this:

              # get var name
              tmp.th1 <- sapply(
                strsplit(tmp.th, split = "\\|t"),
                "[[", 1
              )
              # get number, and sort
              tmp.th2 <- as.character(sort(as.integer(sapply(
                strsplit(tmp.th, split = "\\|t"), "[[", 2
              ))))
              # paste back togehter in the right order
              paste(tmp.th1, tmp.th2, sep = "|t")
            }), use.names = FALSE)
          } else {
            out <- character(0L)
          }
          return.value$th[[b]] <- out
        }

        # thresholds and mean/intercepts of numeric variables
        if (any("th.mean" == type)) {
          # if fixed.x -> use ov.names.nox
          # else -> use ov.names
          if (is.null(partable$exo) || all(partable$exo == 0L)) {
            tmp.ov.names <- ov.names
          } else {
            tmp.ov.names <- ov.names.nox
          }
          if (length(tmp.ov.names) > 0L) {
            # return in the right order (following ov.names.nox!)
            out <- unlist(lapply(tmp.ov.names, function(x) {
              if (x %in% ord.names) {
                idx <- which(x == tmp.th.lhs)
                tmp.th <- unique(paste(tmp.th.lhs[idx], "|",
                  tmp.th.rhs[idx],
                  sep = ""
                ))
                # make sure the th's are in increasing order
                # get var name
                tmp.th1 <- sapply(
                  strsplit(tmp.th, split = "\\|t"),
                  "[[", 1
                )
                # get number, and sort
                tmp.th2 <- as.character(sort(as.integer(sapply(
                  strsplit(tmp.th, split = "\\|t"), "[[", 2
                ))))
                # paste back togehter in the right order
                paste(tmp.th1, tmp.th2, sep = "|t")
              } else {
                x
              }
            }), use.names = FALSE)
          } else {
            out <- character(0L)
          }
          return.value$th.mean[[b]] <- out
        }

        # exogenous lv's
        if (any(c("lv.x", "lv.nox") %in% type)) {
          tmp <- lv.names[!lv.names %in% c(v.ind, eqs.y)]
          lv.names.x <- lv.names[lv.names %in% tmp]
        }

        if (any("lv.x" == type)) {
          return.value$lv.x[[b]] <- lv.names.x
        }

        # dependent ov (but not also indicator or x)
        if (any("ov.y" == type)) {
          tmp <- eqs.y[!eqs.y %in% c(v.ind, eqs.x, lv.names)]
          return.value$ov.y[[b]] <- ov.names[ov.names %in% tmp]
        }

        # dependent lv (but not also indicator or x)
        if (any("lv.y" == type)) {
          tmp <- eqs.y[!eqs.y %in% c(v.ind, eqs.x) &
            eqs.y %in% lv.names]
          return.value$lv.y[[b]] <- lv.names[lv.names %in% tmp]
        }

        # non-exogenous latent variables
        if (any("lv.nox" == type)) {
          return.value$lv.nox[[b]] <- lv.names[!lv.names %in% lv.names.x]
        }

        # marker indicator (if any) for each lv
        if (any("lv.marker" == type)) {
          # default: "" per lv
          out <- character(length(lv.names))
          names(out) <- lv.names
          for (l in seq_len(length(lv.names))) {
            this.lv.name <- lv.names[l]
            # try to see if we can find a 'marker' indicator for this factor
            # here defined as: has a fixed-to-one factor loading
            marker.idx <- which(block.ind &
              partable$op == "=~" &
              partable$lhs == this.lv.name &
              partable$rhs %in% v.ind &
              partable$ustart == 1L &
              partable$free == 0L)
            if (length(marker.idx) > 0L) {
              # we may have multiple potential markers
              potential.markers <- partable$rhs[marker.idx]
              valid.markers <- character(0L)
              for (m in seq_along(potential.markers)) {
                this.marker.idx <- marker.idx[m]
                # check if 'other' loadings are fixed to zero
                other.idx <- which(block.ind &
                  partable$op == "=~" &
                  partable$lhs != this.lv.name &
                  partable$rhs == partable$rhs[this.marker.idx] &
                  partable$free == 0L)
                if (length(other.idx) == 0L) {
                  # simple structure, or one factor
                  valid.markers <- c(valid.markers,
                                     partable$rhs[this.marker.idx])
                } else if (all(partable$ustart[other.idx] == 0)) {
                  valid.markers <- c(valid.markers,
                                     partable$rhs[this.marker.idx])
                }
              }
              if (length(valid.markers) > 0L) {
                out[l] <- valid.markers[1L] # pick the first one
              }
            }
          } # l
          return.value$lv.marker[[b]] <- out
        }
      }
    } # b

    # ----- lav_partable_vnames ---- no cache ------------------------
    # new in 0.6-14: if 'da' operator, change order! (for ov.order = "data")
    # now via attribute "ovda"
    ov.names.data <- attr(partable, "ovda")
    if (!is.null(ov.names.data)) {
      return.value <- lapply(return.value, function(x) {
        for (b in seq_len(length(x))) {
          m <- match(x[[b]], ov.names.data)
          target.idx <- which(!is.na(m))
          if (length(target.idx) > 1L) {
            x[[b]][target.idx] <- x[[b]][target.idx][order(m[target.idx])]
          }
        }
        x
      })
    }
  }
  # ----- lav_partable_vnames ---- common ------ 1 type --------
  # to mimic old behaviour, if length(type) == 1L
  if (length(type) == 1L) {
    return.value <- return.value[[type]]
    # to mimic old behaviour, if specific block is requested
    if (ndotdotdot == 0L) {
      if (type == "lv.marker") {
        return.value <- unlist(return.value)
        # no unique(), as unique() drops attributes, and reduces
        # c("", "", "") to a single ""
        # (but, say for 2 groups, you get 2 copies)
        # as this is only for 'display', we leave it like that
      } else {
        return.value <- unique(unlist(return.value))
      }
    } else if (length(block.select) == 1L) {
      return.value <- return.value[[block.select]]
    } else {
      return.value <- return.value[block.select]
    }
  }
  # ----- lav_partable_vnames ---- common ------------------------
  return.value
}

# find ALL (eligible) *model-implied* instrumental variables (no pruning yet)
#
# three algorithms:
#   1) using 'total effects' of errors/disturbances, based on Bollen & Bauer
#      (2004) [algorithm = "bb2004"]
#   2) treating errors/disturbances as latent variables (as in the
#      comprehensive RAM model); similar to miivs() in MIIVsem package
#      [algorithm = "miivsem"]
#   3) using an explicity expression (due to Albert Maydeu-Olivares) for
#      cov(u,y) [algorithm = "covuy"] (the default)
#
# YR 29 Dec 2025 - first version (bb2004 + miivsem)
# YR 24 Jan 2025 - covuy algorithm (including higher-order factors)

lav_model_find_iv <- function(lavobject = NULL, lavmodel = NULL,
                              lavpta = NULL, algorithm = "covuy",
                              output = "list", drop.list.single.group = FALSE) {
  # check output
  output <- tolower(output)
  stopifnot(output %in% c("list", "table"))

  # lavobject or components?
  if (!is.null(lavobject)) {
    stopifnot(inherits(lavobject, "lavaan"))
    lavpta <- lavobject@pta
    lavmodel <- lavobject@Model
  }

  # sanity checks
  nblocks <- lavpta$nblocks
  for (b in seq_len(nblocks)) {
    lv.idx <- lavpta$vidx$lv.regular[[b]]
    lv.marker <- lavpta$vnames$lv.marker[[b]]
    if (length(lv.idx) > 0L) {
      # do have 'clear' marker/scaling indicators?
      empty.idx <- which(nchar(lv.marker) == 0L)
      if (length(empty.idx) > 0L) {
        tmp_string <- paste(names(lv.marker)[empty.idx], collapse = " ")
        lav_msg_stop(gettextf("no clear marker/scaling indicator found for
                               factor(s): %s", tmp_string))
      }
      # marker/scaling indicator cannot be a dependent variable in an ~ equation
      badmarker.idx <- which(lv.marker %in% lavpta$vnames$eqs.y[[b]])
      if (length(badmarker.idx) > 0L) {
        tmp_string <- paste(lv.marker[badmarker.idx], collapse = " ")
        lav_msg_stop(gettextf("marker/scaling indicator cannot be a dependent
                               variable in a regression: %s", tmp_string))
      }
    }
  }

  algorithm <- tolower(algorithm)
  if (algorithm == "bb2004") {
    iv_list <- lav_model_find_iv_bb2004(lavmodel = lavmodel, lavpta = lavpta)
  } else if (algorithm == "miivsem") {
    iv_list <- lav_model_find_iv_miivsem(lavmodel = lavmodel, lavpta = lavpta)
  } else {
    iv_list <- lav_model_find_iv_covuy(lavmodel = lavmodel, lavpta = lavpta)
  }

  if (output == "table") {
    table <- vector("list", length = nblocks)
    for (b in seq_len(nblocks)) {
      eqs <- iv_list[[b]]
      lhs <- sapply(eqs, "[[", "lhs")
      rhs <- sapply(lapply(eqs, "[[", "rhs"), paste, collapse = " + ")
      lhs_new <- sapply(eqs, "[[", "lhs_new")
      rhs_new <- sapply(lapply(eqs, "[[", "rhs_new"), paste, collapse = " + ")
      miiv <- sapply(lapply(eqs, "[[", "miiv"), paste, collapse = ", ")
      table[[b]] <- data.frame(
        lhs = lhs, rhs = rhs,
        lhs_new = lhs_new, rhs_new = rhs_new, miiv = miiv
      )
      class(table[[b]]) <- c("lavaan.data.frame", "data.frame")
    }
    out <- table
  } else {
    out <- iv_list
  }

  if (nblocks == 1L && drop.list.single.group) {
    out <- out[[1]]
  }

  out
}


# algorithm 1:
# loosely based on Bollen & Bauer (2004), but with support for higher-order
# factors
lav_model_find_iv_bb2004 <- function(lavmodel = NULL, lavpta = NULL) {
  # check representation
  if (lavmodel@representation != "LISREL") {
    lav_msg_stop(gettext(
      "this function only works with LISREL representation",
      " (for now)"
    ))
  }

  # create model matrices with 'user/partable' entries
  glist <- lavmodel@GLIST
  for (mm in seq_along(glist)) {
    dimnames(glist[[mm]]) <- lavmodel@dimNames[[mm]]
    m.idx <- lavmodel@m.user.idx[[mm]]
    x.idx <- lavmodel@x.user.idx[[mm]]
    glist[[mm]][, ] <- 0.0
    glist[[mm]][m.idx] <- x.idx
  }

  # number of blocks
  nblocks <- lavpta$nblocks
  lambda.idx <- which(names(glist) == "lambda")
  beta.idx <- which(names(glist) == "beta")
  psi.idx <- which(names(glist) == "psi")
  theta.idx <- which(names(glist) == "theta")
  if (lavmodel@meanstructure) {
    nu.idx <- which(names(glist) == "nu")
    alpha.idx <- which(names(glist) == "alpha")
  }

  # repeat for every block
  iv_list <- vector("list", length = nblocks)
  for (b in seq_len(nblocks)) {
    # extract information to create Bollen & Bauer (2004) matrices
    ov.names <- lavpta$vnames$ov[[b]]
    nvar <- length(ov.names)
    lv.names <- lavpta$vnames$lv.regular[[b]]
    lv.marker <- lavpta$vnames$lv.marker[[b]]
    lv.marker.orig <- lavpta$vnames$lv.marker[[b]]
    lv.ho <- lavpta$vnames$lv.ho[[b]]

    lv.idx <- lavpta$vidx$lv.regular[[b]]
    lv.x.idx <- lavpta$vidx$lv.x[[b]]
    lv.marker.idx <- lavpta$vidx$lv.marker[[b]]

    # dummy y?
    if (length(lavmodel@ov.y.dummy.ov.idx[[b]]) > 0L) {
      lv.idx <- c(lv.idx, lavmodel@ov.y.dummy.lv.idx[[b]])
      lv.marker <- c(lv.marker.orig, ov.names[lavmodel@ov.y.dummy.ov.idx[[b]]])
      names(lv.marker) <- c(
        names(lv.marker.orig),
        ov.names[lavmodel@ov.y.dummy.ov.idx[[b]]]
      )
      lv.marker.idx <- c(lv.marker.idx, lavmodel@ov.y.dummy.ov.idx[[b]])
    }

    # keep track of higher order factors
    lv.ho.idx <- which(is.na(lv.marker.idx)) # same as lavpta$vidx$lv.ho
    if (length(lv.ho.idx) > 0L) {
      lv_in_marker <- lv.marker[lv.marker %in% lv.names]
      while (length(lv_in_marker) > 0L) {
        new_markers <- unname(lv.marker[lv_in_marker])
        lv.marker[match(lv_in_marker, lv.marker)] <- new_markers
        lv_in_marker <- lv.marker[lv.marker %in% lv.names]
      }
      lv.marker.idx <- match(lv.marker, ov.names)
    }

    # model matrices for this block
    lambda <- glist[[lambda.idx[b]]]
    beta <- glist[[beta.idx[b]]]
    theta <- glist[[theta.idx[b]]]
    psi <- glist[[psi.idx[b]]]
    if (lavmodel@meanstructure) {
      nu <- glist[[nu.idx[b]]]
      alpha <- glist[[alpha.idx[b]]]
    }
    if (is.null(beta)) {
      beta <- matrix(0, ncol(lambda), ncol(lambda))
      colnames(beta) <- rownames(beta) <- colnames(lambda)
    }

    # binary model matrices: nonzero = 1, zero = 0
    if (length(lv.idx) == 0L) {
      lambda_bin <- diag(nrow = ncol(lambda))
    } else {
      lambda_bin <- (lambda != 0) * 1L
    }
    beta_bin <- (beta != 0) * 1L
    ibinv <- solve(diag(nrow(beta_bin)) - beta_bin)
    ibinv_bin <- (ibinv != 0) * 1L

    # construct pred
    if (length(lv.idx) > 0L) {
      reg_bin <- rbind(lambda_bin, beta_bin)
      pred_orig <- rbind(lambda, beta)
      if (lavmodel@meanstructure) {
        int_orig <- rbind(nu, alpha)
      }
    } else {
      reg_bin <- beta_bin
      pred_orig <- beta
      if (lavmodel@meanstructure) {
        int_orig <- alpha
      }
    }
    pred.idx <- numeric(ncol(reg_bin))
    if (length(lv.marker.idx) > 0L) {
      pred.idx[lv.idx] <- lv.marker.idx
    }
    if (length(lavmodel@ov.x.dummy.ov.idx[[b]]) > 0L) {
      pred.idx[lavmodel@ov.x.dummy.lv.idx[[b]]] <-
        lavmodel@ov.x.dummy.ov.idx[[b]]
    }
    if (length(lavmodel@ov.y.dummy.ov.idx[[b]]) > 0L) {
      pred.idx[lavmodel@ov.y.dummy.lv.idx[[b]]] <-
        lavmodel@ov.y.dummy.ov.idx[[b]]
    }
    tmp <- t(t(reg_bin) * pred.idx)
    # remove scaling '1' for markers (if any)
    if (length(lv.marker.idx) > 0L) {
      row.idx <- match(lv.marker.orig, rownames(tmp))
      col.idx <- match(names(lv.marker.orig), colnames(tmp))
      tmp[cbind(row.idx, col.idx)] <- 0L
    }
    # keep only the 'ov' part
    pred <- tmp[seq_along(ov.names), , drop = FALSE]
    # replace marker rows, with beta entries of their corresponding lv's
    # dummy y + regular lv's
    if (length(lv.idx) > 0L && !is.null(beta)) {
      tmp_lv <- tmp_lv2 <- tmp[length(ov.names) + lv.idx, , drop = FALSE]
      orig_lv <- pred_orig[length(ov.names) + lv.idx, , drop = FALSE]
      if (lavmodel@meanstructure) {
        int_lv <- int_orig[length(ov.names) + lv.idx, , drop = FALSE]
        tmp_lv2 <- cbind(int_lv, tmp_lv)
      }

      # tmp[lv.marker.idx, ] <- tmp[length(ov.names) + lv.idx, ]
      # careful, lv.marker.idx may contain the same element multiple times!
      zerolv.idx <- which(apply(tmp_lv2, 1, function(x) all(x == 0)))
      if (length(zerolv.idx) > 0L) {
        tmp_lv <- tmp_lv[-zerolv.idx, , drop = FALSE]
        orig_lv <- orig_lv[-zerolv.idx, , drop = FALSE]
        if (lavmodel@meanstructure) {
          int_lv <- int_lv[-zerolv.idx, , drop = FALSE]
        }
      }
      r.idx <- match(lv.marker[rownames(tmp_lv)], rownames(pred))
      pred[r.idx, ] <- tmp_lv
      pred_orig[r.idx, ] <- orig_lv
      rownames(pred_orig)[r.idx] <- rownames(tmp_lv)
      pred_orig <- pred_orig[1:nvar, , drop = FALSE]
      if (lavmodel@meanstructure) {
        int_orig[r.idx, ] <- int_lv
        # also exogenous ov's!
        lv.x.dummy.idx <- lavmodel@ov.x.dummy.lv.idx[[b]]
        if (length(lv.x.dummy.idx) > 0L) {
          int_orig[lavmodel@ov.x.dummy.ov.idx[[b]],1] <- alpha[lv.x.dummy.idx,1]
        }
        rownames(int_orig)[r.idx] <- rownames(int_lv)
        int_orig <- int_orig[1:nvar, , drop = FALSE]
      }
    }
    # non-zero entries of 'pred' contain the marker idx of the latent
    # predictors (and perhaps the dummy ov indices)

    # construct comp (composite error term)
    # - for each dependent: the corresponding element in Theta/Psi (y_res)
    # - for each (latent) predictor: the corresponding *marker* element in
    #   Theta (x_res)
    # - for the markers: the disturbance (psi) of the corresponding
    #   lv's (included in x_res)
    # - for higher-order factors: the disturbance (psi) of their 'marker'
    #   factor
    y_res <- diag(theta)
    if (length(lv.marker.idx) > 0L) {
      x_res <- pred
      # x_res[pred != 0] <- y_res[as.vector(pred[pred != 0])]
      x_res[pred != 0] <- y_res[pred]
      x_res[cbind(lv.marker.idx, seq_along(lv.idx))] <- diag(psi)[lv.idx]
      if (length(lv.ho.idx) > 0L) {
        # higher-order factors: what are their indicators?
        # add diag(psi) value in this row
        x_res <- t(apply(x_res, 1, function(x) {
          res <- x
          hof <- x[lv.ho.idx]
          hof_nonzero <- hof[hof != 0]
          if (length(hof_nonzero) > 0L) {
            # keep going until we only have first-order factors (or ovs)
            target <- unname(lv.marker.orig[names(hof_nonzero)])
            ho_in_target <- target[target %in% lv.ho]
            while (length(ho_in_target) > 0L) {
              new <- unname(lv.marker.orig[ho_in_target])
              target <- c(target, new)
              ho_in_target <- new[new %in% lv.ho]
            }

            if (length(target)) {
              res[target] <- diag(psi)[target]
            }
          }
          res
        }))
      }
      # comp <- cbind(y_res, x_res)[1:nvar, ]
      comp <- cbind(y_res, x_res)
    } else {
      # no latent variables
      comp <- cbind(y_res)
    }

    # construct total: total effects of errors/disturbances on
    #                  EACH observed variable in the model
    # - direct effect of 'epsilon': diag(theta)
    # - total effect of 'disturbance': Lambda %*% (I - Beta)^{-1}
    lv_res <- diag(psi)
    lv_res[lv.x.idx] <- 0 # remove 'total/exo' variances from psi
    y_res <- diag(theta)
    t_res <- t(t(lambda_bin %*% ibinv_bin) * lv_res)
    total <- cbind(y_res, t_res)

    # construct piv (potential ivs):
    # initial set of potential instruments for each equation, by selecting
    # observed variables that are unaffected by the disturbances or
    # uniquenesses in that equation
    piv <- matrix(1:nvar, nrow = nvar, ncol = nvar, byrow = TRUE)
    colnames(piv) <- rownames(piv) <- ov.names
    for (i in 1:nvar) {
      res_id <- unique(comp[i, comp[i, ] != 0])
      tmp <- apply(total, 2, function(x) !x %in% res_id)
      rm.idx <- which(!apply(tmp, 1, all))
      piv[i, rm.idx] <- 0
    }
    # diagonal must be zero (not needed, but just to be safe)
    diag(piv) <- 0
    # ov.y -> zero column
    if (length(lavpta$vidx$ov.y[[b]]) > 0L) {
      piv[, lavpta$vidx$ov.y[[b]]] <- 0
    }
    # ov.x -> zero row
    if (length(lavpta$vidx$ov.x[[b]]) > 0L) {
      piv[lavpta$vidx$ov.x[[b]], ] <- 0
    }


    # construct iv
    # Starting from piv, remove any potential ivs that are affected by a
    # disturbance that correlates with any disturbance in the composite
    # disturbance term
    iv <- piv
    for (i in 1:nvar) {
      # check if we need instruments at all
      rhs <- pred[i, pred[i, ] != 0, drop = FALSE]
      if (length(rhs) > 0L && all(comp[i, colnames(rhs)] == 0)) {
        # no instruments needed
        iv[i, -rhs] <- 0
      } else {
        for (p in 1:nvar) {
          # do check for this iv, if false, set to zero
          comp.idx <- which(y_res %in% comp[i, ])
          total.idx <- which(y_res %in% total[piv[i, p], ])
          cov_values <- theta[as.matrix(expand.grid(comp.idx, total.idx))]
          if (any(cov_values != 0)) {
            iv[i, p] <- 0
          }
        }
      } # instruments needed
    }

    # add intercepts here
    if (lavmodel@meanstructure) {
      colnames(int_orig) <- "1"
      pred <- cbind(int_orig, pred)
      pred_orig <- cbind(int_orig, pred_orig)

      idx <- match(names(lv.marker), rownames(pred))
      rownames(pred)[idx] <- lv.marker
    }

    # remove 'empty' rows
    empty.idx <- which(apply(pred, 1L, function(x) all(x == 0)) &
      rownames(pred) %in% ov.names)
    if (length(empty.idx) > 0L) {
      iv <- iv[-empty.idx, , drop = FALSE]
      comp <- comp[-empty.idx, , drop = FALSE]
      pred <- pred[-empty.idx, , drop = FALSE]
      pred_orig <- pred_orig[-empty.idx, , drop = FALSE]
      if (lavmodel@meanstructure) {
        int_orig <- int_orig[-empty.idx, , drop = FALSE]
      }
    }
    # replace row/colnames of pred by marker names
    idx <- match(names(lv.marker), colnames(pred))
    colnames(pred)[idx] <- lv.marker

    # prepare list
    eqs <- vector("list", length = nrow(iv))
    for (j in seq_along(eqs)) {
      cet <- colnames(comp)[which(comp[j, ] != 0)]
      x.idx <- which(pred[j, ] != 0)
      ptint <- integer(0L)
      if (lavmodel@meanstructure) {
        x.idx <- x.idx[-1]
        ptint <- unname(pred_orig[j, 1])
      }
      if (lavmodel@meanstructure && length(x.idx) == 0L) {
        rhs_new <- "1"
        rhs <- "1"
        miiv <- "1"
      } else {
        rhs_new <- colnames(pred[j, x.idx, drop = FALSE])
        rhs <- colnames(pred_orig[j, x.idx, drop = FALSE])
        miiv <- colnames(iv[j, iv[j, ] != 0, drop = FALSE])
      }
      eqs[[j]] <- list(
        lhs_new = rownames(pred)[j],
        rhs_new = rhs_new,
        lhs = rownames(pred_orig)[j],
        rhs = rhs,
        pt = unname(pred_orig[j, x.idx]),
        ptint = ptint,
        cet = cet,
        markers = unique(lv.marker[cet[-1]]),
        miiv = miiv
      )
    }

    # reorder so that ov lhs come first, then lv lhs
    lhs <- sapply(eqs, "[[", "lhs")
    ov.idx <- match(ov.names[ov.names %in% lhs], lhs)
    lv.idx <- seq_along(lhs)[-ov.idx]
    eqs <- eqs[c(ov.idx, lv.idx)]

    iv_list[[b]] <- eqs
  } # blocks

  iv_list
}

# algorithm 2: create a model where error/disturbance terms are latent
#              variables (a bit like the comprehensive RAM representation)
#              and compute 'big_sigma':
#              - to identify ov's that are uncorrelated with the errors in
#                the composite error term
#              - to identify ov's that are correlated with at least one
#                marker
#              the intersection give the (full list of) miivs
#
# the implementation below is loosely based on (but not identical to) the
# 'miivs()' function from the MIIVsem package
#
lav_model_find_iv_miivsem <- function(lavmodel = NULL, lavpta = NULL) {
  # check representation
  if (lavmodel@representation != "LISREL") {
    lav_msg_stop(gettext(
      "this function only works with LISREL representation",
      " (for now)"
    ))
  }

  # create model matrices with 'user/partable' entries
  glist <- lavmodel@GLIST
  for (mm in seq_along(glist)) {
    dimnames(glist[[mm]]) <- lavmodel@dimNames[[mm]]
    m.idx <- lavmodel@m.user.idx[[mm]]
    x.idx <- lavmodel@x.user.idx[[mm]]
    glist[[mm]][, ] <- 0.0
    glist[[mm]][m.idx] <- x.idx
  }
  lambda.idx <- which(names(glist) == "lambda")
  beta.idx <- which(names(glist) == "beta")
  psi.idx <- which(names(glist) == "psi")
  theta.idx <- which(names(glist) == "theta")
  if (lavmodel@meanstructure) {
    nu.idx <- which(names(glist) == "nu")
    alpha.idx <- which(names(glist) == "alpha")
  }

  # nblocks
  nblocks <- lavmodel@nblocks

  # repeat for every block
  iv_list <- vector("list", length = nblocks)
  for (b in seq_len(nblocks)) {
    lv.names <- lavpta$vnames$lv.regular[[b]]
    ov.names <- lavpta$vnames$ov[[b]]
    lv.marker <- lavpta$vnames$lv.marker[[b]]

    # model matrices for this block
    lambda <- glist[[lambda.idx[b]]]
    beta <- glist[[beta.idx[b]]]
    theta <- glist[[theta.idx[b]]]
    psi <- glist[[psi.idx[b]]]
    if (lavmodel@meanstructure) {
      nu <- glist[[nu.idx[b]]]
      alpha <- glist[[alpha.idx[b]]]
    }


    # 'exogenous' variables (in beta/psi) (including dummy ov's)
    if (is.null(beta)) {
      lv.x.idx <- lavpta$vidx$lv.x[[b]]
    } else {
      lv.x.idx <- which(apply(beta, 1L, function(x) all(x == 0)))
    }

    # lambda+beta
    if (is.null(beta)) {
      beta <- matrix(0, ncol(lambda), ncol(lambda))
    }
    lambda_beta <- rbind(lambda, beta)
    pred_orig <- lambda_beta
    lambda_beta[lambda_beta != 0] <- as.numeric(NA)
    # add markers
    row.idx <- match(lavpta$vnames$lv.marker[[b]], rownames(lambda_beta))
    col.idx <- match(names(lavpta$vnames$lv.marker[[b]]), colnames(lambda_beta))
    lambda_beta[cbind(row.idx, col.idx)] <- 1
    pred <- lambda_beta
    pred_orig_full <- pred_orig
    empty.idx <- which(apply(lambda_beta, 1L, function(x) all(x == 0)))
    if (length(empty.idx) > 0) {
      lambda_beta <- lambda_beta[-empty.idx, , drop = FALSE]
      pred_orig <- pred_orig[-empty.idx, , drop = FALSE]
    }

    # error + zero matrix, to create gamma and beta
    error_matrix <- diag(nrow = nrow(lambda_beta))
    rownames(error_matrix) <- rownames(lambda_beta)
    colnames(error_matrix) <- paste("e.", rownames(lambda_beta), sep = "")
    zero_matrix <- error_matrix * 0
    colnames(zero_matrix) <- rownames(lambda_beta)

    # construct gamma
    gamma <- cbind(
      lambda_beta[, lv.x.idx, drop = FALSE],
      error_matrix
    )
    gamma_orig <- cbind(
      pred_orig[, lv.x.idx, drop = FALSE],
      error_matrix
    )

    # construct beta
    beta <- beta_orig <- zero_matrix
    tmp <- lambda_beta[, -lv.x.idx, drop = FALSE]
    beta[, colnames(tmp)] <- tmp
    tmp <- pred_orig[, -lv.x.idx, drop = FALSE]
    beta_orig[, colnames(tmp)] <- tmp

    # construct Phi
    Phi <- lav_matrix_bdiag(
      psi[lv.x.idx, lv.x.idx, drop = FALSE],
      theta,
      psi[-lv.x.idx, -lv.x.idx, drop = FALSE]
    )
    empty.idx <- which(apply(Phi, 1L, function(x) all(x == 0)))
    if (length(empty.idx) > 0) {
      Phi <- Phi[-empty.idx, -empty.idx, drop = FALSE]
    }
    colnames(Phi) <- rownames(Phi) <- colnames(gamma)
    Phi[Phi != 0] <- as.numeric(NA)

    tmp <- crossprod(gamma)
    tmp[, ] <- 0
    Beta <- lav_matrix_bdiag(beta, tmp)
    I <- diag(nrow(Beta))
    diag(tmp) <- 1
    Gamma <- rbind(gamma, tmp)

    # to compute big_sigma, we can replace NA by 1
    Beta[is.na(Beta)] <- 1
    Gamma[is.na(Gamma)] <- 1
    Phi[is.na(Phi)] <- 1
    ib_inv <- solve(I - Beta)
    big_sigma <- ib_inv %*% Gamma %*% Phi %*% t(Gamma) %*% t(ib_inv)
    sigma_ov <- big_sigma[ov.names, , drop = FALSE] # only rows with ov.names
    e_names <- colnames(gamma)[grep("e\\.", colnames(gamma))]


    # matrix of all regressions (nothing has been removed yet, here)
    gamma_beta <- pred
    gamma_beta_orig <- pred_orig_full

    # add intercepts here
    if (lavmodel@meanstructure) {
      int <- rbind(nu, alpha); colnames(int) <- "1"
      int_orig <- int
      int[int != 0] <- as.numeric(NA)
      idx <- match(lv.marker, rownames(int))
      int[idx, 1] <- 1
      gamma_beta <- cbind(int, gamma_beta)
      gamma_beta_orig <- cbind(int_orig, gamma_beta_orig)
    }

    # select only those rows of gamma_beta that have at least one free (NA)
    # element
    free.idx <- which(apply(is.na(gamma_beta), 1, any))
    eqs_y_free <- unique(rownames(gamma_beta)[free.idx])
    eqs <- vector("list", length = length(eqs_y_free))
    for (j in seq_along(eqs)) {
      # lhs
      eq_lhs <- eq_lhs_orig <- eqs_y_free[j]

      # index in gamma_beta
      jj <- free.idx[j]

      # lhs + rhs
      zero.idx <- which(gamma_beta[jj, ] != 0) # fixed or error term
      na.idx <- which(is.na(gamma_beta[jj, ])) # free/NA
      eq_rhs <- eq_rhs_orig <- colnames(gamma_beta)[c(zero.idx, na.idx)]
      pt <- unname(gamma_beta_orig[jj, na.idx])
      ptint <- integer(0L)
      if (lavmodel@meanstructure) {
        ptint <- unname(int_orig[jj, 1L])
        eq_rhs <- eq_rhs[-1]
        eq_rhs_orig <- eq_rhs_orig[-1]
      }
      eq_all <- c(eq_lhs, eq_rhs)

      # markers + composite error term (cet)
      cet <- paste("e.", eq_lhs, sep = "")

      # replace all latent variables by their markers
      markers <- character(0L)
      lv_in_eq <- eq_all[eq_all %in% lv.names]
      if (length(lv_in_eq) > 0L) {
        markers <- unname(lv.marker[lv_in_eq])
        # replace in eq_all
        eq_all[match(lv_in_eq, eq_all)] <- markers
        # add marker errors to composite error term
        cet <- c(cet, paste("e.", markers, sep = ""))
      }

      # any markers that are still latent? (eg higher-order factors)
      if (any(eq_all %in% lv.names)) {
        lv_in_eq <- eq_all[eq_all %in% lv.names]
        while (length(lv_in_eq) > 0L) {
          new_markers <- unname(lv.marker[lv_in_eq])
          eq_all[match(lv_in_eq, eq_all)] <- new_markers
          markers[match(lv_in_eq, markers)] <- new_markers
          cet <- c(cet, paste("e.", new_markers, sep = ""))
          lv_in_eq <- eq_all[eq_all %in% lv.names]
        }
      }
      markers <- unique(markers)
      eq_lhs <- eq_all[1]
      eq_rhs <- eq_all[-1]

      if (length(eq_rhs) > 0L) {
        # observed variables that are uncorrelated with all the components of
        # the composite error term
        ov_uncorrelated_with_cet <-
          ov.names[apply(sigma_ov[, cet, drop = FALSE] == 0, 1L, all)]

        # observed variables that have at least one non-zero implied correlation
        # with any of the marker indicators (vector i).
        ov_correlated_with_markers <-
          ov.names[apply(sigma_ov[, markers, drop = FALSE] != 0, 1, all)]

        # valid instruments
        miivs <- intersect(ov_uncorrelated_with_cet, ov_correlated_with_markers)
     } else {
        eq_rhs <- "1"
        eq_rhs_orig <- "1"
        miivs <- "1"
     }

      eqs[[j]] <- list(
        lhs_new = eq_lhs,
        rhs_new = eq_rhs,
        lhs = eq_lhs_orig,
        rhs = eq_rhs_orig,
        pt = pt,
        ptint = ptint,
        cet = cet,
        markers = markers,
        miiv = miivs
      )
    }

    # reorder so that ov lhs come first, then lv lhs
    lhs <- sapply(eqs, "[[", "lhs")
    ov.idx <- match(ov.names[ov.names %in% lhs], lhs)
    lv.idx <- seq_along(lhs)[-ov.idx]
    eqs <- eqs[c(ov.idx, lv.idx)]

    iv_list[[b]] <- eqs
  } # nblocks


  iv_list
}

# algorithm 3:
# - use random data to create sigma (used to check if predictors are correlated
#   with instruments)
# - use an explicit expression to compute cov(u,y), where u_j is the disturbance
#   term of an equation (used to verify that instruments are not correlated
#   with this disturbance term)
lav_model_find_iv_covuy <- function(lavmodel = NULL, lavpta = NULL) {
  # check representation
  if (lavmodel@representation != "LISREL") {
    lav_msg_stop(gettext(
      "this function only works with LISREL representation",
      " (for now)"
    ))
  }

  # create model matrices with 1) 'user/partable' entries, 2) random entries
  glist <- glistr <- lavmodel@GLIST
  glist_names <- names(glist)
  for (mm in seq_along(glist)) {
    dimnames(glist[[mm]]) <- lavmodel@dimNames[[mm]]
    m.idx <- lavmodel@m.user.idx[[mm]]
    x.idx <- lavmodel@x.user.idx[[mm]]
    # partable entries
    glist[[mm]][, ] <- 0.0
    glist[[mm]][m.idx] <- x.idx
    # random entries (overriding user specified!)
    f.idx <- lavmodel@m.free.idx[[mm]]
    glistr[[mm]][f.idx] <- (runif(length(f.idx), min = 0.1, max = 0.5) *
      sign(runif(length(f.idx), min = -1, max = 1)))
    if (glist_names[mm] %in% c("theta", "psi")) {
      tmp <- glistr[[mm]]
      # make sure diagonal is large enough (but only for nonzero values)
      zerodiag.idx <- which(diag(tmp) == 0)
      diag(tmp) <- diag(tmp) + 1.5
      diag(tmp)[zerodiag.idx] <- 0
      # make symmetric
      glistr[[mm]] <- (tmp + t(tmp)) / 2
    }
  }

  # generate random sigma per block
  sigma <- lav_model_sigma(lavmodel, GLIST = glistr, extra = FALSE)
  sigma_aug <- lav_model_cov_both(lavmodel, GLIST = glistr)

  # number of blocks
  nblocks <- lavpta$nblocks
  lambda.idx <- which(glist_names == "lambda")
  beta.idx <- which(glist_names == "beta")
  if (lavmodel@meanstructure) {
    nu.idx <- which(names(glist) == "nu")
    alpha.idx <- which(names(glist) == "alpha")
  }


  # repeat for every block
  iv_list <- vector("list", length = nblocks)
  for (b in seq_len(nblocks)) {
    # extract information to create Bollen & Bauer (2004) matrices
    ov.names <- lavmodel@dimNames[[lambda.idx[b]]][[1]]
    lv.names <- lavmodel@dimNames[[lambda.idx[b]]][[2]]
    both.names <- c(ov.names, lv.names)
    nvar <- length(ov.names)
    nfac <- length(lv.names)

    # model matrices for this block
    lambda <- glist[[lambda.idx[b]]]
    beta <- glist[[beta.idx[b]]]
    if (is.null(beta)) {
      beta <- matrix(0, nfac, nfac)
    }
    if (lavmodel@meanstructure) {
      nu <- glist[[nu.idx[b]]]
      alpha <- glist[[alpha.idx[b]]]
    }

    # sigma + sigma_aug
    this_sigma <- sigma[[b]]
    rownames(this_sigma) <- colnames(this_sigma) <- ov.names
    this_sigma_aug <- sigma_aug[[b]]
    rownames(this_sigma_aug) <- colnames(this_sigma_aug) <- both.names

    lambdar <- glistr[[lambda.idx[b]]]
    if (is.null(glistr[[beta.idx[b]]])) {
      betar <- diag(1, nrow = nfac)
    } else {
      betar <- glistr[[beta.idx[b]]]
    }

    # all markers (including higher-order)
    lv.marker <- lv.names
    names(lv.marker) <- lv.names
    lv.marker[match(names(lavpta$vnames$lv.marker[[b]]), lv.names)] <-
      lavpta$vnames$lv.marker[[b]]
    lv.marker.idx <- match(lv.marker, both.names)

    # construct cov_u_y
    pi_mat <- rbind(lambdar, betar)
    rownames(pi_mat) <- both.names
    colnames(pi_mat) <- lv.names
    pi_mat[lv.marker.idx, ] <- betar
    pi_zero_mat <- matrix(0, nrow = nrow(pi_mat), ncol = nrow(pi_mat))
    pi_zero_mat[, lv.marker.idx] <- pi_mat
    cov_u_y_aug <- this_sigma_aug - pi_zero_mat %*% this_sigma_aug
    # zap small elements to be exactly zero
    cov_u_y_aug[abs(cov_u_y_aug) < 1e-07] <- 0.0

    if (length(lavpta$vnames$lv.ho[[b]]) > 0L) {
      # 'add' lv marker rows to ov marker rows
      ov.marker <- lv.marker
      lv.names.nox <- lv.names[!lv.names %in% ov.names]
      lv_in_marker <- lv_beta <- ov.marker[ov.marker %in% lv.names.nox]
      while (length(lv_in_marker) > 0L) {
        new_markers <- unname(ov.marker[lv_in_marker])
        ov.marker[match(lv_in_marker, ov.marker)] <- new_markers
        lv_in_marker <- ov.marker[ov.marker %in% lv.names.nox]
      }
      ho.idx <- match(names(lv_beta), both.names)
      target.idx <- match(ov.marker[names(lv_beta)], both.names)
      cov_u_y_aug[target.idx, ] <-
        cov_u_y_aug[target.idx, ] + cov_u_y_aug[ho.idx, ]
    } else {
      ov.marker <- lv.marker
    }
    cov_u_y <- cov_u_y_aug[seq_len(nvar), seq_len(nvar)]

    # construct pred
    pred <- rbind(lambda, beta)

    # if meanstructure, add intercepts
    if (lavmodel@meanstructure) {
      int <- rbind(nu, alpha)
      colnames(int) <- "1" # shorter than "intercept"
      pred <- cbind(int, pred)
    }

    pred_orig <- pred
    # replace col/rownames of pred by marker names
    idx <- match(names(ov.marker), colnames(pred))
    idx <- idx[!is.na(idx)]
    colnames(pred)[idx] <- ov.marker
    idx <- match(names(ov.marker), rownames(pred))
    idx <- idx[!is.na(idx)]
    rownames(pred)[idx] <- ov.marker

    # remove scaling '1' for markers (if any)
    if (length(lv.marker.idx) > 0L) {
      pred[lv.marker.idx, ] <- 0
    }

    # remove 'empty' rows
    empty.idx <- which(apply(pred, 1L, function(x) all(x == 0)))
    if (length(empty.idx) > 0L) {
      pred <- pred[-empty.idx, , drop = FALSE]
      pred_orig <- pred_orig[-empty.idx, , drop = FALSE]
    }

    # prepare list
    eqs <- vector("list", length = nrow(pred))
    for (j in seq_along(eqs)) {
      lhs <- rownames(pred)[j]
      x.idx <- which(pred[j, ] != 0)
      rhs <- colnames(pred)[x.idx]
      ptint <- integer(0L)
      if (lavmodel@meanstructure && pred[j, 1] != 0) {
        ptint <- unname(pred_orig[j, 1])
        rhs <- rhs[-1]
        x.idx <- x.idx[-1]
      }

      # instruments needed?
      iv_flag <- TRUE
      if (lavmodel@meanstructure && length(x.idx) == 0L) {
        iv_flag <- FALSE
        miiv <- "1"
      } else if (all(cov_u_y[lhs, rhs] == 0)) {
        iv_flag <- FALSE
        miiv <- rhs
      } else {
        # correlated with at least one predictor
        correlated_with_pred <- apply(
          this_sigma[, rhs, drop = FALSE], 1L,
          function(x) any(x != 0)
        )
        # instruments should be uncorrelated with the  term of the eq (u_j)
        uncorrelated_with_u <- cov_u_y[lhs, ] == 0
        miiv <- ov.names[correlated_with_pred & uncorrelated_with_u]
      }

      # prepare rhs, rhs_new, pt
      if (length(x.idx) == 0) {
        rhs_new <- "1"
        rhs <- "1"
        pt <- integer(0L)
      } else {
        rhs_new <- colnames(pred[j, x.idx, drop = FALSE])
        rhs <- colnames(pred_orig[j, x.idx, drop = FALSE])
        pt <- as.integer(unname(pred_orig[j, x.idx]))
      }

      eqs[[j]] <- list(
        lhs_new = rownames(pred)[j],
        rhs_new = rhs_new,
        lhs = rownames(pred_orig)[j],
        rhs = rhs,
        pt = pt,
        ptint = ptint,
        iv_flag = iv_flag,
        miiv = miiv
      )
    }

    # reorder so that ov lhs come first, then lv lhs
    lhs <- sapply(eqs, "[[", "lhs")
    ov.idx <- match(ov.names[ov.names %in% lhs], lhs)
    lv.idx <- seq_along(lhs)[-ov.idx]
    eqs <- eqs[c(ov.idx, lv.idx)]

    iv_list[[b]] <- eqs
  }

  iv_list
}

# This function takes as input a plotinfo structure with two data.frames:
#   nodes: id, naam, tiepe, voorkeur, blok
#   edges: id, label, van, naar, tiepe
# , parameters to control the placement of nodes and edge labels, a
# switch to indicate whether indicators for which a covariance is explicit in
# the model should be grouped at the same side of the graph and a debug
# switch.
# It returns a plotinfo strucure with modified nodes and edges data.frames and
# an integer mlrij giving the position at which a line should be drawn for
# multilevel models.
# The data.frames have new columns defined as follows:
# nodes:
#   rij: index of the row where the node will be placed.
#   kolom: ndex of the column where the node will be placed.
# edges
#   vananker: character, anchor point for starting node.
#   naaranker: character, anchor point for destination node.
#   controlpt.kol: real, column position of control point if the
#     edge has to be drawn as a quadratic Beziers curve.
#   controlpt.row: real, row position of control point if the
#     edge has to be drawn as a quadratic Beziers curve.
#   labelbelow: logical, TRUE if label has to be positioned under
#     the line, initalized FALSE.
#
lav_plotinfo_positions <- function(
  plotinfo,
  placenodes = NULL,
  edgelabelsbelow = NULL,
  group.covar.indicators = FALSE,
  debug = FALSE
) {
  # add new columns to nodes and edges data.frames
  nodes <- plotinfo$nodes
  nodes$rij <- NA_integer_
  nodes$kolom <- NA_integer_
  edges <- plotinfo$edges
  edges$vananker <- NA_character_
  edges$naaranker <- NA_character_
  edges$controlpt.kol <- NA_real_
  edges$controlpt.rij <- NA_real_
  edges$labelbelow <- FALSE
  # if only one node, place it at (1, 1) and return
  if (length(nodes$rij) == 1L) {
    # Only 1 node, e.g. model = 'x ~~ x'
    nodes$rij[1L] <- 1L
    nodes$kolom[1L] <- 1L
    return(list(
      nodes = nodes,
      edges = edges,
      mlrij = 0L
    ))
  }
  # if there are multiple levels, split the plotinfo in two and call function
  # lav_plotinfo_positions_one separately for the two levels and combine the
  # results
  if (any(nodes$blok > 0L)) {
    # Multilevel, only level:1 and level:2 accepted
    nodes1 <- nodes[nodes$blok >= 2L, ]
    edges1 <- edges[edges$van %in% nodes1$id, ]
    edges1$van <- match(edges1$van, nodes1$id)
    edges1$naar <- match(edges1$naar, nodes1$id)
    nodes1$id <- seq_along(nodes1$tiepe)
    nodes1$blok <- 0L
    nodes2 <- nodes[nodes$blok == 1L, ]
    edges2 <- edges[edges$van %in% nodes2$id, ]
    edges2$van <- match(edges2$van, nodes2$id)
    edges2$naar <- match(edges2$naar, nodes2$id)
    nodes2$id <- seq_along(nodes2$tiepe)
    nodes2$blok <- 0L
    result1 <- lav_plotinfo_positions_one(
      list(nodes = nodes1, edges = edges1),
      placenodes,
      edgelabelsbelow,
      group.covar.indicators,
      debug
    )
    result2 <- lav_plotinfo_positions_one(
      list(nodes = nodes2, edges = edges2),
      placenodes,
      edgelabelsbelow,
      group.covar.indicators,
      debug
    )
    rijen1 <- max(result1$nodes$rij)
    result2$nodes$rij <- result2$nodes$rij + rijen1 + 1L
    result2$edges$controlpt.rij <- result2$edges$controlpt.rij + rijen1 + 1L
    result1$nodes$blok <- 2L
    result2$nodes$blok <- 1L
    result2$nodes$id <- result2$nodes$id + length(result1$nodes)
    result2$edges$van <- result2$edges$van + length(result1$nodes)
    result2$edges$naar <- result2$edges$naar + length(result1$nodes)
    nodes <- rbind(result1$nodes, result2$nodes)
    edges <- rbind(result1$edges, result2$edges)
    return(list(
      nodes = nodes,
      edges = edges,
      mlrij = rijen1 + 1L
    ))
  }
  # if there is only one level, call function lav_plotinfo_positions_one
  plotinfo <- list(nodes = nodes, edges = edges)
  lav_plotinfo_positions_one(
    plotinfo,
    placenodes,
    edgelabelsbelow,
    group.covar.indicators,
    debug
  )
}

# This function computes the positions for the nodes and the anchors and
# control points for the edges in the diagram for a single level.
lav_plotinfo_positions_one <- function(
  plotinfo,
  placenodes,
  edgelabelsbelow,
  group.covar.indicators,
  debug
) {
  nods <- plotinfo$nodes
  edgs <- plotinfo$edges
  # assign groupnumbers to the nodes, i.e. partition the nodes in groups
  # which belong together, e.g. indicators and the corresponding latent
  # variable
  nods <- lav_plotinfo_nodes_groups(plotinfo, group.covar.indicators)
  plotinfo <- list(nodes = nods, edges = edgs)
  # compute the information for the groups
  groups <- lav_plotinfo_groups(plotinfo)
  # order the groups in a matrix via topological sorting
  groups <- lav_groups_order(groups, plotinfo)
  # debug <- TRUE
  if (debug) {
    cat("debug start\nnodes\n")
    nods1 <- within(nods, {
      rm(blok, rij, kolom)
    })
    print(nods1)
    cat("edges\n")
    edgs1 <- within(edgs, {
      rm(vananker, naaranker, controlpt.kol, controlpt.rij)
    })
    print(edgs1)
    rm(edgs1, nods1)
    cat("matrix with groups after ordening\n")
    print(lav_groups_matrix(groups))
    cat("debug end\n")
  }
  for (g in seq_along(groups)) {
    group <- groups[[g]]
    group <- lav_group_order(group, plotinfo)
    if (debug && group$nb.nodes > 1L) {
      plot(group$offsets.lin, -group$offsets.out,
        pch = 16, xlim = c(0, 1 + max(group$offsets.lin)),
        axes = FALSE, main = paste("Group", g))
      arrows(0.5, 0, 0.5, -max(group$offsets.out), col = "blue")
      text(0.6, -0.6, "out", col = "blue")
      text(group$offsets.lin  + 0.2, -group$offsets.out,
           nods$naam[group$nodes.id])
    }
    groups[[g]] <- group
  }
  width <- sapply(groups, function(g) g$width.height[1L])
  height <- sapply(groups, function(g) g$width.height[2L])
  columns <- sapply(groups, function(g) g$matrixrowcol[2L])
  rows <- sapply(groups, function(g) g$matrixrowcol[1L])
  colnums <- sort(unique(columns))
  rownums <- sort(unique(rows))
  colwidths <- sapply(colnums, function(i) max(width[columns == i]))
  rowheights <- sapply(rownums, function(i) max(height[rows == i]))
  for (g in groups) {
    thisrow <- g$matrixrowcol[1L]
    thiscol <- g$matrixrowcol[2L]
    gtop <- 1L
    if (thisrow > 1L) gtop <- gtop + cumsum(rowheights)[thisrow - 1L]
    gleft <- 1L
    if (thiscol > 1L) gleft <- gleft + cumsum(colwidths)[thiscol - 1L]
    for (n in seq_along(g$nodes.id)) {
      k <- which(nods$id == g$nodes.id[n])
      if (g$loc == "l" || g$loc == "?") {
        nods$rij[k] <- gtop + g$offsets.lin[n]
        nods$kolom[k] <- gleft + colwidths[g$matrixrowcol[2L]] -
                         g$offsets.out[n] - 1L
      } else if (g$loc == "r") {
        nods$rij[k] <- gtop + g$offsets.lin[n]
        nods$kolom[k] <- gleft + g$offsets.out[n]
      } else if (g$loc == "t") {
        nods$rij[k] <- gtop + rowheights[1] - g$offsets.out[n] - 1L
        nods$kolom[k] <- gleft + g$offsets.lin[n]
      } else if (g$loc == "b") {
        nods$rij[k] <- gtop + g$offsets.out[n]
        nods$kolom[k] <- gleft + g$offsets.lin[n]
      }
    }
  }
  # compress graph by joining adjacent rows without common column-elements and
  # adjacent columns without common row-elements
  maxrow <- max(nods$rij)
  maxcol <- max(nods$kolom)
  for (j in seq(maxrow - 1L, 1L, -1L)) {
    col1 <- nods$kolom[nods$rij == j]
    col2 <- nods$kolom[nods$rij == j + 1L]
    if (all(is.na(match(col1, col2)))) {
      dimins <- which(nods$rij > j)
      nods$rij[dimins] <- nods$rij[dimins] - 1L
    }
  }
  for (j in seq(maxcol - 1L, 1L, -1L)) {
    col1 <- nods$rij[nods$kolom == j]
    col2 <- nods$rij[nods$kolom == j + 1L]
    if (all(is.na(match(col1, col2)))) {
      dimins <- which(nods$kolom > j)
      nods$kolom[dimins] <- nods$kolom[dimins] - 1L
    }
  }
  # check for debug
  if (debug) {
      plot(nods$kolom, -nods$rij,
        pch = 16, xlim = c(0, 1 + max(nods$kolom)), axes = FALSE,
        main = "Absolute positions nodes")
      text(nods$kolom + 0.3, -nods$rij, nods$naam)
  }
  #### place nodes demanded by user ? ####
  if (!is.null(placenodes)) {
    for (nn in names(placenodes)) {
      w <- which(nods$naam == nn)
      if (length(w) == 0) {
        lav_msg_warn(gettextf("placenodes: node name %s not found!", nn))
      }
      nods$rij[w] <- placenodes[[nn]][1L]
      nods$kolom[w] <- placenodes[[nn]][2L]
    }
  }
  #### place anchors ####
  groupmaxcol <- max(sapply(groups, function(g) g$matrixrowcol[2L]))
  groupmaxrow <- max(sapply(groups, function(g) g$matrixrowcol[1L]))
  for (j in seq_along(edgs$id)) {
    thisedge <- edgs[j, ]
    van <- nods[which(nods$id == thisedge$van), ]
    naar <- nods[which(nods$id == thisedge$naar), ]
    vangroup <- groups[[van$group]]
    if (thisedge$tiepe == "=~") { # define latent variable
      if (vangroup$matrixrowcol[[2L]] == 1L) {
        thisedge$vananker <- "w"
        thisedge$naaranker <- "e"
      } else if (vangroup$matrixrowcol[[2L]] == groupmaxcol) {
        thisedge$vananker <- "e"
        thisedge$naaranker <- "w"
      } else if (vangroup$matrixrowcol[[1L]] == 1L) {
        thisedge$vananker <- "n"
        thisedge$naaranker <- "s"
      } else if (vangroup$matrixrowcol[[1L]] == groupmaxrow) {
        thisedge$vananker <- "s"
        thisedge$naaranker <- "n"
      }
    } else if (thisedge$tiepe == "<~") { # define composite variable
      if (vangroup$matrixrowcol[[2L]] == 1L) {
        thisedge$vananker <- "e"
        thisedge$naaranker <- "w"
      } else if (vangroup$matrixrowcol[[2L]] == groupmaxcol) {
        thisedge$vananker <- "w"
        thisedge$naaranker <- "e"
      } else if (vangroup$matrixrowcol[[1L]] == 1L) {
        thisedge$vananker <- "s"
        thisedge$naaranker <- "n"
      } else if (vangroup$matrixrowcol[[1L]] == groupmaxrow) {
        thisedge$vananker <- "n"
        thisedge$naaranker <- "s"
      }
    } else if (thisedge$tiepe == "~." || thisedge$tiepe == "~") {
      # regression/varlv
      if (van$rij == naar$rij) {
        thisedge$vananker <- if (van$kolom < naar$kolom) "e" else "w"
        thisedge$naaranker <- if (van$kolom < naar$kolom) "w" else "e"
      } else if (van$kolom == naar$kolom) {
        thisedge$vananker <- if (van$rij < naar$rij) "s" else "n"
        thisedge$naaranker <- if (van$rij < naar$rij) "n" else "s"
      } else {
        thisedge <- lav_plotinfo_anchors(thisedge, van, naar,
                                         max(nods$kolom), max(nods$rij))
      }
    } else if (thisedge$tiepe == "~~~") { # (remaining) variance
        thisedge <- lav_plotinfo_anchors(thisedge, van, naar,
                                         max(nods$kolom), max(nods$rij))
    } else { # covariance
        thisedge <- lav_plotinfo_anchors(thisedge, van, naar,
                                         max(nods$kolom), max(nods$rij))
    }
    edgs[j, ] <- thisedge
  }
  #### labelsbelow demanded by user ? ####
  if (!is.null(edgelabelsbelow)) {
    for (i in seq_along(edgelabelsbelow)) {
      n1 <- which(nods$naam == edgelabelsbelow[[i]][1L])
      if (length(n1) == 0) {
        lav_msg_warn(gettextf(
          "edgelabelsbelow: node name %s not found!",
          edgelabelsbelow[[i]][1L]
        ))
      }
      n2 <- which(nods$naam == edgelabelsbelow[[i]][2L])
      if (length(n2) == 0) {
        lav_msg_warn(gettextf(
          "edgelabelsbelow: node name %s not found!",
          edgelabelsbelow[[i]][2L]
        ))
      }
      ed <- which(
        edgs$van == nods$id[n1] &
          edgs$naar == nods$id[n2]
      )
      if (length(ed) == 0L) {
        ed <- which(edgs$naar == nods$id[n1] & edgs$van == nods$id[n2])
      }
      if (length(ed) == 0L) {
        lav_msg_warn(
          gettextf(
            "edgelabelsbelow: edge %s -- %s not found!",
            nods$naam[n1],
            nods$naam[n2]
          )
        )
      }
      edgs$labelbelow[ed] <- TRUE
    }
  }
  #### RETURN ####
  list(nodes = nods, edges = edgs, mlrij = 0L)
}

lav_plotinfo_nodes_groups <- function(plotinfo, group.covar.indicators) {
  nodes <- plotinfo$nodes
  edges <- plotinfo$edges
  nodes$group <- seq.int(nrow(nodes)) # each node in its own group
  merge_groups <- function(group, i1, i2) { # merge group of i1 into group of i2
    group[group == group[i1]] <- group[i2]
    group
  }
  indicator.ids <- lav_plotinfo_indicator_ids(nodes, edges)
  # process edges to form groups
  for (j in seq.int(nrow(edges))) {
    van.id <- which(nodes$id == edges$van[j])
    naar.id <- which(nodes$id == edges$naar[j])
    merge.them <- FALSE
    if (edges$tiepe[j] == "=~") {
      if (nodes$tiepe[naar.id] != "lv" && nodes$tiepe[naar.id] != "cv") {
        merge.them <- TRUE
      }
    } else if (edges$tiepe[j] == "<~") {
      if (nodes$tiepe[van.id] != "lv" && nodes$tiepe[van.id] != "cv") {
        merge.them <- TRUE
      }
    } else if (edges$tiepe[j] == "~.") {
      merge.them <- TRUE
    } else if (edges$tiepe[j] == "~~") {
      if (group.covar.indicators &&
        any(edges$van[j] == indicator.ids) &&
        any(edges$naar[j] == indicator.ids)
      ) {
        merge.them <- TRUE
      }
    } else if (edges$tiepe[j] == "~") {
      if (nodes$tiepe[van.id] == "varlv") {
        merge.them <- TRUE
      }
    }
    if (merge.them) {
      nodes$group <- merge_groups(nodes$group, naar.id, van.id)
    }
  }
  nodes$group <- match(nodes$group, unique(nodes$group)) # renumber 1:n
  nodes
}
lav_plotinfo_indicator_ids <- function(nodes, edges) {
  # compute ids of observed indicators
  indicator.ids <- unique(c(
    edges$naar[edges$tiepe == "=~"],
    edges$van[edges$tiepe == "<~"]
  ))
  for (i in seq_along(indicator.ids)) {
    indicator.id <- which(nodes$id == indicator.ids[i])
    if (
      nodes$tiepe[indicator.id] == "lv" ||
        nodes$tiepe[indicator.id] == "cv"
    ) {
      indicator.ids[i] <- 0L
    }
  }
  indicator.ids <- indicator.ids[indicator.ids != 0L]
  indicator.ids
}
lav_plotinfo_groups <- function(plotinfo) {
  nodes <- plotinfo$nodes
  edges <- plotinfo$edges
  nb.of.groups <- max(nodes$group)
  indicator.ids <- lav_plotinfo_indicator_ids(nodes, edges)
  groups <- lapply(seq_len(nb.of.groups), function(g) {
    group <- list(
      id = g,
      nodes.id = integer(),
      edges.id = integer(),
      offsets.out = integer(),
      offsets.lin = integer(),
      nb.nodes = integer(),
      nb.indicators = 0L,
      measurement = FALSE,
      loc = "?",
      matrixrowcol = c(0L, 0L),
      width.height = c(1L, 1L),
      indic = ""
    )
    group$nodes.id <- which(nodes$group == g)
    group$nodes.id <- nodes$id[group$nodes.id]
    group$edges.id <- which(
      edges$van %in% group$nodes.id & edges$naar %in% group$nodes.id
    )
    group$edges.id <- edges$id[group$edges.id]
    group$nb.nodes <- length(group$nodes.id)
    group$nb.indicators <-
      as.integer(sum(nodes$group[nodes$id %in% indicator.ids] == g))
    group$measurement <- (group$nb.indicators > 0L)
    group
  })
  groups
}
lav_groups_matrix <- function(groups) {
  maxrow <- 1L
  maxcol <- 1L
  for (group in groups) {
    rowcol <- group$matrixrowcol
    if (rowcol[1L] > maxrow) {
      maxrow <- rowcol[1L]
    }
    if (rowcol[2L] > maxcol) {
      maxcol <- rowcol[2L]
    }
  }
  m <- matrix(0L, nrow = maxrow, ncol = maxcol)
  for (group in groups) {
    rowcol <- group$matrixrowcol
    m[rowcol[1L], rowcol[2L]] <- group$id
  }
  m
}

 # internal ordering of a group
 lav_group_order <- function(group.object, plotinfo) {
  edges <- plotinfo$edges
  group <- group.object
  group$offsets.out <- rep(0L, group$nb.nodes)
  group$offsets.lin <- rep(0L, group$nb.nodes)
  if (group$nb.nodes > 1L) {
    defined <- integer()
    definedby <- integer()
    bordernodes <- integer()
    for (j in group$edges.id) {
      thisedge <- edges[which(edges$id == j), ]
      if (thisedge$tiepe == "~.") {
        definedby <- c(definedby, thisedge$van)
        defined <- c(defined, thisedge$naar)
      } else {
        if (thisedge$tiepe == "=~") {
          definedby <- c(definedby, thisedge$naar)
          defined <- c(defined, thisedge$van)
          bordernodes <- c(bordernodes, thisedge$van)
        } else if (thisedge$tiepe == "<~") {
          definedby <- c(definedby, thisedge$van)
          defined <- c(defined, thisedge$naar)
          bordernodes <- c(bordernodes, thisedge$naar)
        } else { # include nodes not yet present indefined or definedby
          if (!(thisedge$van %in% definedby || thisedge$van %in% defined)) {
            definedby <- c(definedby, thisedge$van)
            defined <- c(defined, 999L)
          }
          if (!(thisedge$naar %in% definedby || thisedge$naar %in% defined)) {
            definedby <- c(definedby, thisedge$naar)
            defined <- c(defined, 999L)
          }
        }
      }
    }
    internaldf <- lav_graph_topological_matrix(defined, definedby,
                                               bordernodes = bordernodes)
    for (j in seq_along(group$nodes.id)) {
      group$offsets.lin[j] <- internaldf$rows[internaldf$nodes ==
                                              group$nodes.id[j]] - 1L
      group$offsets.out[j] <- max(internaldf$cols) -
          internaldf$cols[internaldf$nodes == group$nodes.id[j]]
    }
  }
  if (group$loc == "l" || group$loc == "r" || group$loc == "?") {
    group$width.height <- c(
      1L + max(group$offsets.out),
      1L + max(group$offsets.lin)
    )
  } else {
    group$width.height <- c(
      1L + max(group$offsets.lin),
      1L + max(group$offsets.out)
    )
  }
  group
 }

lav_groups_order <- function(groups, plotinfo) {
  nodes <- plotinfo$nodes
  edges <- plotinfo$edges
  dependencies <- data.frame(defined = integer(0), definedby = integer(0))
  add_dependency <- function(depends, def, defby) {
    if (any(depends$defined == def & depends$definedby == defby)) {
      return(depends)
    }
    rbind(depends, data.frame(defined = def, definedby = defby))
  }
  for (j in seq_along(edges$id)) {
    van.id <- which(nodes$id == edges$van[j])
    naar.id <- which(nodes$id == edges$naar[j])
    if (nodes$group[van.id] == nodes$group[naar.id]) {
      next
    }
    if (edges$tiepe[j] == "=~") {
      if (nodes$tiepe[naar.id] == "lv" || nodes$tiepe[naar.id] == "cv") {
        dependencies <- add_dependency(
          dependencies,
          nodes$group[van.id],
          nodes$group[naar.id]
        )
      }
    } else if (edges$tiepe[j] == "<~") {
      if (nodes$tiepe[van.id] == "lv" || nodes$tiepe[van.id] == "cv") {
        dependencies <- add_dependency(
          dependencies,
          nodes$group[naar.id],
          nodes$group[van.id]
        )
      }
    } else if (edges$tiepe[j] == "~") {
      dependencies <- add_dependency(
        dependencies,
        nodes$group[naar.id],
        nodes$group[van.id]
      )
    }
  }
  bordernodes <- integer(0)
  for (g in groups) {
    if (g$measurement) bordernodes <- c(bordernodes, g$id)
  }
  if (nrow(dependencies) == 0L) {
    for (g in groups) dependencies <- add_dependency(dependencies, 999, g$id)
  }
  groupmatrixdf <- lav_graph_topological_matrix(
    dependencies$defined,
    dependencies$definedby,
    bordernodes = bordernodes,
    warn = TRUE
  )
  for (g in seq_along(groups)) {
    group <- groups[[g]]
    gmcol <- which(groupmatrixdf$nodes == group$id)
    group$matrixrowcol <- as.integer(c(
      groupmatrixdf$rows[gmcol],
      groupmatrixdf$cols[gmcol]
    ))
    group$indic <- groupmatrixdf$indic[gmcol]
    groups[[g]] <- group
  }
  rm(groupmatrixdf)
  # Set loc = "l" for all measurement groups in first column.
  # Set loc = "r" for all measurement groups in last column.
  # Set loc = "t" for measurement groups in first row and
  #                               not first or last column.
  # Set loc = "b" for measurement groups in another row and
  #                               not first or last column.
  group.matrix <- lav_groups_matrix(groups)
  gmcols <- ncol(group.matrix)
  for (g in seq_along(groups)) {
    group <- groups[[g]]
    if (group$measurement) {
      if (group$matrixrowcol[2L] == 1L) {
        group$loc <- "l"
      } else if (group$matrixrowcol[2L] == gmcols) {
        group$loc <- "r"
      } else {
        if (group$matrixrowcol[1L] == 1L) {
          group$loc <- "t"
        } else {
          group$loc <- "b"
        }
      }
      groups[[g]] <- group
    }
  }
  groups
}

lav_points_normalform <- function(p1, p2) {
  # compute normal form of a line
  # the constant in the normal form will always be <= 0
  xy1 <- matrix(
    c(
      p1, 1, p2, 1
    ),
    byrow = TRUE,
    ncol = 3
  )
  a <- det(xy1[, 2:3])
  b <- -det(xy1[, c(
    1L, 3L
  )])
  c <- det(xy1[, 1:2])
  fac <- 1 / sqrt(a * a + b * b)
  if (c > 0) {
    fac <- -fac
  }
  fac *
    c(
      a, b, c
    )
}
lav_pointslope_normalform <- function(p, slope) {
  # compute normal form of a line defined by intercept a and slope b
  # a vertical line is defined by x = a and b = Inf or -Inf
  if (is.infinite(slope)) {
    return(c(
      1, 0, -p[1]
    ))
  }
  coeffs <- c(
    -slope, 1, slope * p[1] - p[2]
  ) /
    sqrt(1 + slope^2)
  if (coeffs[3] > 0) {
    coeffs <- -coeffs
  }
  coeffs
}
lav_lines_intersection <- function(line1, line2) {
  # get the intersection point of two lines for which coefficients of
  # equations are given
  m <- matrix(
    c(
      line1[1:2], line2[1:2]
    ),
    byrow = TRUE,
    ncol = 2L
  )
  b <- matrix(
    c(
      -line1[3], -line2[3]
    ),
    ncol = 1L
  )
  if (abs(det(m)) < 1e-12) {
    return(NA_real_)
  }
  as.vector(solve(m) %*% b)
}
lav_edge_bezierscontrolpoint <- function(van, naar, maxrij, maxcol) {
  middelpunt <- c(
    maxrij + 1, maxcol + 1
  ) /
    2
  delta <- sqrt(sum((van - naar)^2)) /
    sqrt(sum(
      c(
        maxrij - 1, maxcol - 1
      )^2
    ))
  lijn <- lav_points_normalform(van, naar)
  middenlijn <- (van + naar) / 2
  lijnmidden <- sum(
    lijn *
      c(
        middelpunt, 1
      )
  )
  if (lijnmidden > 0) {
    lijn[3] <- lijn[3] + 0.5 + delta
  } else {
    lijn[3] <- lijn[3] - 0.5 - delta
  }
  orthoslope <- lijn[2] / lijn[1]
  loodlijn <- lav_pointslope_normalform(middenlijn, orthoslope)
  lav_lines_intersection(lijn, loodlijn)
}
lav_edge_bezierscp_corner <- function(van, naar, wvannaar, maxrij, maxcol) {
  dif <- (abs(van[1L] - naar[1L]) + abs(van[2L] - naar[2L]) - 1) /
    (maxrij + maxcol - 2)
  p <- switch(wvannaar,
    ne = ,
    en = c(
      1, maxcol
    ) +
      c(
        -dif, dif
      ),
    nw = ,
    wn = c(
      1, 1
    ) +
      c(
        -dif, -dif
      ),
    se = ,
    es = c(
      maxrij, maxcol
    ) +
      c(
        dif, dif
      ),
    sw = ,
    ws = c(
      maxrij, 1
    ) +
      c(
        dif, -dif
      )
  )
  2 * (p - 0.25 * (van + naar))
}

lav_plotinfo_anchors <- function(edge, nodevan, nodenaar, maxkol, maxrij) {
  if (edge$tiepe == "~~~") {
    if (nodevan$kolom == 1L) {
      edge$vananker <- "w"
      edge$naaranker <- "w"
    } else if (nodevan$kolom == maxkol) {
      edge$vananker <- "e"
      edge$naaranker <- "e"
    } else if (nodevan$rij == 1L) {
      edge$vananker <- "n"
      edge$naaranker <- "n"
    } else if (nodevan$rij == maxrij) {
      edge$vananker <- "s"
      edge$naaranker <- "s"
    } else {
      edge$vananker <- "n"
      edge$naaranker <- "n"
    }
  } else if (edge$tiepe == "~~") {
    thrucorner <- FALSE
    if (edge$tiepe == "~~") {
      if (nodevan$kolom == nodenaar$kolom) {
        if (nodevan$kolom < maxkol / 2) {
          edge$vananker <- edge$naaranker <- "w"
        } else {
          edge$vananker <- edge$naaranker <- "e"
        }
      } else if (nodevan$rij == nodenaar$rij) {
        if (nodevan$rij < maxrij / 2) {
          edge$vananker <- edge$naaranker <- "n"
        } else {
          edge$vananker <- edge$naaranker <- "s"
        }
      } else {
        if (nodevan$rij < nodenaar$rij) {
          if (nodevan$kolom < nodenaar$kolom) {
            if (nodevan$kolom == 1L && nodenaar$rij == maxrij) {
              edge$vananker <- "w"
              edge$naaranker <- "s"
              thrucorner <- TRUE
            } else {
              edge$vananker <- "s"
              edge$naaranker <- "w"
            }
          } else {
            if (nodevan$kolom == maxkol && nodenaar$rij == maxrij) {
              edge$vananker <- "e"
              edge$naaranker <- "s"
              thrucorner = TRUE
            } else {
              edge$vananker <- "s"
              edge$naaranker <- "e"
            }
            }
        } else {
          if (nodevan$kolom < nodenaar$kolom) {
            if (nodevan$kolom == 1L && nodenaar$rij == 1L) {
              edge$vananker <- "w"
              edge$naaranker <- "n"
              thrucorner <- TRUE
            } else {
              edge$vananker <- "n"
              edge$naaranker <- "w"
            }
          } else {
            if (nodevan$kolom == maxkol && nodenaar$rij == 1L) {
              edge$vananker <- "e"
              edge$naaranker <- "n"
              thrucorner <- TRUE
            } else {
              edge$vananker <- "n"
              edge$naaranker <- "e"
            }
          }
        }
      }
      if (thrucorner) {
        bc <- lav_edge_bezierscp_corner(
                  c(
          nodevan$rij, nodevan$kolom
        ),
        c(
          nodenaar$rij, nodenaar$kolom
        ),
        paste0(edge$vananker, edge$naaranker),
        maxrij,
        maxkol
        )
      } else {
      bc <- lav_edge_bezierscontrolpoint(
        c(
          nodevan$rij, nodevan$kolom
        ),
        c(
          nodenaar$rij, nodenaar$kolom
        ),
        maxrij,
        maxkol
      )
      }
      edge$controlpt.rij <- bc[1L]
      edge$controlpt.kol <- bc[2L]
    }
  } else {
    breaks <- c(
    -pi - 0.01,
    -7 * pi / 8,
    -5 * pi / 8,
    -3 * pi / 8,
    -pi / 8,
    pi / 8,
    3 * pi / 8,
    5 * pi / 8,
    7 * pi / 8,
    pi + 0.01
    )
    winds <- c("w", "sw", "s", "se", "e", "ne", "n", "nw", "w")
    hoek <- atan2(nodevan$rij - nodenaar$rij, nodenaar$kolom - nodevan$kolom)
    wind <- cut(hoek, breaks, winds)
    edge$vananker <- as.character(wind)
    if (hoek > 0) {
      hoek <- hoek - pi
    } else {
      hoek <- hoek + pi
    }
    wind <- cut(hoek, breaks, winds)
    edge$naaranker <- as.character(wind)
  }
  edge
}

# efa related functions
# YR - April 2019
#
# the lav_model_efa_rotate_x() function was based on a script orginally
# written by Florian Scharf (Muenster University, Germany)

# rotate solution
lav_model_efa_rotate <- function(lavmodel = NULL, lavoptions = NULL) {

  # sanity check
  if (lavmodel@nefa == 0L || lavoptions$rotation == "none") {
    return(lavmodel)
  }

  # save warn and verbos settings
  current.warn <- lav_warn()
  current.verbose <- lav_verbose()

  # extract unrotated parameters from lavmodel
  x.orig <- lav_model_get_parameters(lavmodel, type = "free", extra = FALSE)

  # rotate, extract information from 'extra' attribute
  tmp <- lav_model_efa_rotate_x(
    x = x.orig, lavmodel = lavmodel,
    lavoptions = lavoptions, extra = TRUE
  )
  extra <- attr(tmp, "extra")
  attr(tmp, "extra") <- NULL

  out <- list(GLIST = extra$GLIST, H = extra$H, lv.order = extra$lv.order)

  # restore warn/verbose settings
  lav_warn(current.warn)
  lav_verbose(current.verbose)

  out
}


# lower-level function, needed for numDeriv
lav_model_efa_rotate_x <- function(x, lavmodel = NULL, lavoptions = NULL,
                                   init.rot = NULL, extra = FALSE,
                                   type = "free") {
  # extract rotation options from lavoptions
  method <- lavoptions$rotation
  if (method == "none") {
    return(x)
  }
  ropts <- lavoptions$rotation.args

  # place parameters into model matrices
  lavmodel.orig <- lav_model_set_parameters(lavmodel, x = x)

  # GLIST
  GLIST <- lavmodel.orig@GLIST

  # H per group
  H <- vector("list", lavmodel@ngroups)
  ORDER <- vector("list", lavmodel@ngroups)

  # new in 0.6-22 -- three options:
  # 1. rotate per group (default)
  # 2. group.equal = "loadings": use first lambda matrix only
  # 3. rotate all groups together + agreement (eg De Roover & Vermunt, 2019)
  mg.group.equal.flag <- mg.agreement.flag <- FALSE
  if (lavmodel@ngroups > 1) {
    if("loadings" %in% lavoptions$group.equal) {
      mg.group.equal.flag <- TRUE
    } else if (ropts$mg.agreement) {
      mg.agreement.flag <- TRUE
    }
  }

  # option 1 + 2 (single group or multipgroup + no agreement)
  if (!mg.agreement.flag) {
    for (g in seq_len(lavmodel@ngroups)) {
      # select model matrices for this group
      mm.in.group <- seq_len(lavmodel@nmat[g]) + cumsum(c(0, lavmodel@nmat))[g]
      MLIST <- GLIST[mm.in.group]

      # general rotation matrix (all latent variables)
      H[[g]] <- Hg <- diag(ncol(MLIST$lambda))
      lv.order <- seq_len(ncol(MLIST$lambda))

      # reconstruct full LAMBDA (in case of dummy ov's)
      LAMBDA.g <- lav_lisrel_lambda(
        MLIST = MLIST,
        ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
        ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
        ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
        ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]],
        remove.dummy.lv = TRUE
      )
      # reconstruct full THETA (in case of dummy ov's)
      THETA.g <- lav_lisrel_theta(
        MLIST = MLIST,
        ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
        ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
        ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
        ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]]
      )

      # fill in optimal rotation for each set
      for (set in seq_len(lavmodel@nefa)) {
        # which ov/lv's are involved in this set?
        ov.idx <- lavmodel@ov.efa.idx[[g]][[set]]
        lv.idx <- lavmodel@lv.efa.idx[[g]][[set]]

        # empty set?
        if (length(ov.idx) == 0L) {
          next
        }

        # just 1 factor?
        if (length(lv.idx) < 2L) {
          # new in 0.6-18: reflect if needed
          if (lavoptions$rotation.args$reflect) {
            tmp <- LAMBDA.g[ov.idx, lv.idx, drop = TRUE]
            if (sum(tmp) < 0) {
              MLIST$lambda[ov.idx, 1] <- -1 * MLIST$lambda[ov.idx, 1]
            }
          }
          next
        }

        # unrotated 'A' for this set
        A <- LAMBDA.g[ov.idx, lv.idx, drop = FALSE]

        # std.ov? we use diagonal of Sigma for this set of ov's only
        if (ropts$std.ov) {
          if (mg.group.equal.flag) {
            # compute mean THETA across groups
            theta.idx <- which(names(lavmodel@GLIST) == "theta")
            THETA <- Reduce("+", lavmodel@GLIST[theta.idx]) / lavmodel@ngroups
          } else {
            THETA <- THETA.g[ov.idx, ov.idx, drop = FALSE]
          }
          Sigma <- tcrossprod(A) + THETA
          this.ov.var <- diag(Sigma)
        } else {
          this.ov.var <- NULL
        }

        # init.rot?
        if (!is.null(init.rot) && lavoptions$rotation.args$jac.init.rot) {
          init.ROT <- init.rot[[g]][lv.idx, lv.idx, drop = FALSE]
          rstarts <- 0
        } else {
          init.ROT <- NULL
          rstarts <- ropts$rstarts
        }
        # set warn and verbose to ropts-values
        current.warn <- lav_warn()
        current.verbose <- lav_verbose()
        if (lav_warn(ropts$warn))
          on.exit(lav_warn(current.warn), TRUE)
        if (lav_verbose(ropts$verbose))
          on.exit(lav_verbose(current.verbose), TRUE)
        # rotate this set
        res <- lav_matrix_rotate(
          A = A,
          orthogonal = ropts$orthogonal,
          method = method,
          method.args = list(
            geomin.epsilon = ropts$geomin.epsilon,
            orthomax.gamma = ropts$orthomax.gamma,
            cf.gamma       = ropts$orthomax.gamma,
            oblimin.gamma  = ropts$oblimin.gamma,
            promax.kappa   = ropts$promax.kappa,
            target         = ropts$target,
            target.mask    = ropts$target.mask
          ),
          init.ROT = init.ROT,
          init.ROT.check = FALSE,
          rstarts = rstarts,
          row.weights = ropts$row.weights,
          std.ov = ropts$std.ov,
          ov.var = this.ov.var,
          algorithm = ropts$algorithm,
          reflect = ropts$reflect,
          order.lv.by = ropts$order.lv.by,
          gpa.tol = ropts$gpa.tol,
          tol = ropts$tol,
          max.iter = ropts$max.iter,
  		group = g
        )

        # extract rotation matrix (note, in Asp & Muthen, 2009; this is H')
        # note: as of 0.6-6, order.idx has already been applied to ROT,
        #       so no need to reorder rows/columns after rotation
        H.efa <- res$ROT

        # fill in optimal rotation for this set
        Hg[lv.idx, lv.idx] <- H.efa

        # keep track of possible re-orderings
        lv.order[lv.idx] <- lv.idx[res$order.idx]
      } # set

      # rotate all the SEM parameters

      # 1. lambda
      MLIST$lambda <- t(solve(Hg, t(MLIST$lambda)))

      # 2. psi (note: eq 22 Asp & Muthen, 2009: transpose reversed)
      MLIST$psi <- t(Hg) %*% MLIST$psi %*% Hg

      # 3. beta
      if (!is.null(MLIST$beta)) {
        MLIST$beta <- t(Hg) %*% t(solve(Hg, t(MLIST$beta)))
      }

      # 4. alpha
      if (!is.null(MLIST$alpha)) {
        MLIST$alpha <- t(Hg) %*% MLIST$alpha
      }

      # no need for rotation: nu, theta

      # store rotated matrices in GLIST
      GLIST[mm.in.group] <- MLIST

      # store rotation matrix + lv.order
      H[[g]] <- Hg
      ORDER[[g]] <- lv.order

      # check for group.equal
      if (mg.group.equal.flag) {
        break # only rotation once
      }
    } # group

    # if group.equal = "loadings", take care of the other groups
    if (mg.group.equal.flag) {
      MLIST1 <- MLIST # first group
      for (g in 2:lavmodel@ngroups) {
        mm.in.group <- ( seq_len(lavmodel@nmat[g]) +
                         cumsum(c(0, lavmodel@nmat))[g] )
        MLIST <- GLIST[mm.in.group]
        MLIST$lambda <- MLIST1$lambda
        MLIST$psi <- t(Hg) %*% MLIST$psi %*% Hg
        if (!is.null(MLIST$beta)) {
          MLIST$beta <- t(Hg) %*% t(solve(Hg, t(MLIST$beta)))
        }
        if (!is.null(MLIST$alpha)) {
          MLIST$alpha <- t(Hg) %*% MLIST$alpha
        }
        GLIST[mm.in.group] <- MLIST
        H[[g]] <- Hg
        ORDER[[g]] <- lv.order
      }
    }

  # option 3: rotation + agreement
  } else {
    lambdaList <- vector("list", length = lavmodel@ngroups)
    for (g in seq_len(lavmodel@ngroups)) {
      # select model matrices for this group
      mm.in.group <- seq_len(lavmodel@nmat[g]) + cumsum(c(0, lavmodel@nmat))[g]
      MLIST <- GLIST[mm.in.group]

      # reconstruct full LAMBDA (in case of dummy ov's)
      LAMBDA.g <- lav_lisrel_lambda(
        MLIST = MLIST,
        ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
        ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
        ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
        ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]],
        remove.dummy.lv = TRUE
      )

      lambdaList[[g]] <- LAMBDA.g

      # prepare H and ORDER
      H[[g]] <- diag(ncol(LAMBDA.g))
      ORDER[[g]] <- seq_len(ncol(LAMBDA.g))
    } # group

    # fill in optimal rotation for each set
    for (set in seq_len(lavmodel@nefa)) {
      # which ov/lv's are involved in this set?
      ov.idx <- lavmodel@ov.efa.idx[[1]][[set]] # assumed equal across groups!
      lv.idx <- lavmodel@lv.efa.idx[[1]][[set]] # assumed equal across groups!

      # empty set?
      if (length(ov.idx) == 0L) {
        next
      }

      # just 1 factor?
#       if (length(lv.idx) < 2L) {
#         # new in 0.6-18: reflect if needed
#         if (lavoptions$rotation.args$reflect) {
#           tmp <- LAMBDA.g[ov.idx, lv.idx, drop = TRUE]
#           if (sum(tmp) < 0) {
#             MLIST$lambda[ov.idx, 1] <- -1 * MLIST$lambda[ov.idx, 1]
#           }
#         }
#         next
#       }

      # unrotated 'A' for this set
      Alist <- lapply(lambdaList,
        function (x) { x[ov.idx, lv.idx, drop = FALSE] })
      # std.ov? we use diagonal of Sigma for this set of ov's only
#      if (ropts$std.ov) {
#        if (mg.group.equal.flag) {
#          # compute mean THETA across groups
#          theta.idx <- which(names(lavmodel@GLIST) == "theta")
#          THETA <- Reduce("+", lavmodel@GLIST[theta.idx]) / lavmodel@ngroups
#        } else {
#          THETA <- THETA.g[ov.idx, ov.idx, drop = FALSE]
#        }
#        Sigma <- tcrossprod(A) + THETA
#        this.ov.var <- diag(Sigma)
#      } else {
        this.ov.var <- NULL
#      }

      # init.rot?
      if (!is.null(init.rot) && lavoptions$rotation.args$jac.init.rot) {
        init.rotList <- vector("list", length = lavmodel@ngroups)
        init.rotList[[g]] <- init.rot[[g]][lv.idx, lv.idx, drop = FALSE]
        rstarts <- 0
      } else {
        init.rotList <- NULL
        rstarts <- ropts$rstarts
      }

      # set warn and verbose to ropts-values
      current.warn <- lav_warn()
      current.verbose <- lav_verbose()
      if (lav_warn(ropts$warn))
        on.exit(lav_warn(current.warn), TRUE)
      if (lav_verbose(ropts$verbose))
        on.exit(lav_verbose(current.verbose), TRUE)
      if (lav_verbose()) {
        cat("\n")
      }

      # rotate this set
      res <- lav_matrix_rotate_mg(
        Alist = Alist,
        orthogonal = ropts$orthogonal,
        method = method,
        method.args = list(
          geomin.epsilon = ropts$geomin.epsilon,
          orthomax.gamma = ropts$orthomax.gamma,
          cf.gamma       = ropts$orthomax.gamma,
          oblimin.gamma  = ropts$oblimin.gamma,
          promax.kappa   = ropts$promax.kappa,
          target         = ropts$target,
          target.mask    = ropts$target.mask
        ),
        init.rotList = init.rotList,
        init.ROT.check = FALSE,
        rstarts = rstarts,
        #row.weights = ropts$row.weights,
        #std.ov = ropts$std.ov,
        #ov.var = this.ov.var,
        mg.algorithm = ropts$mg.agreement.algorithm,
        mg.agreement.method = ropts$mg.agreement.method,
        mg.agreement.weight = ropts$mg.agreement.weight,
        reflect = ropts$reflect,
        order.lv.by = ropts$order.lv.by,
        #gpa.tol = ropts$gpa.tol,
        tol = ropts$tol,
        max.iter = ropts$max.iter
      )
      for (g in seq_len(lavmodel@ngroups)) {
        # fill in optimal rotation for this set, for this group
        H[[g]][lv.idx, lv.idx] <- res$rotList[[g]]

        # keep track of possible re-orderings
        ORDER[[g]][lv.idx] <- lv.idx[res$orderList[[g]]]
      }
    } # set

    # rotate all the SEM parameters
    for (g in seq_len(lavmodel@ngroups)) {
      mm.in.group <- seq_len(lavmodel@nmat[g]) + cumsum(c(0, lavmodel@nmat))[g]
      MLIST <- GLIST[mm.in.group]
      Hg <- H[[g]]

      # 1. lambda
      MLIST$lambda <- t(solve(Hg, t(MLIST$lambda)))

      # 2. psi (note: eq 22 Asp & Muthen, 2009: transpose reversed)
      MLIST$psi <- t(Hg) %*% MLIST$psi %*% Hg

      # 3. beta
      if (!is.null(MLIST$beta)) {
        MLIST$beta <- t(Hg) %*% t(solve(Hg, t(MLIST$beta)))
      }

      # 4. alpha
      if (!is.null(MLIST$alpha)) {
        MLIST$alpha <- t(Hg) %*% MLIST$alpha
      }
      # no need for rotation: nu, theta

      GLIST[mm.in.group] <- MLIST
    }

    # rescale lambda again, so that sum-of-squares per columns is the same
    # for all groups
    lambdaList <- GLIST[names(GLIST) == "lambda"]
    psiList    <- GLIST[names(GLIST) == "psi"]

    ss_list <- lapply(lambdaList, function(x) colSums(x^2))
    ss_ave <- Reduce("+", ss_list) / length(ss_list)
    scale_factor <- vector("list", length = ncol(lambdaList[[1]]))
    for(g in seq_len(lavmodel@ngroups)) {
      scale_factor[[g]] <- (sqrt(ss_list[[g]]) / sqrt(ss_ave))
      lambdaList[[g]] <- t( t(lambdaList[[g]]) / scale_factor[[g]] )
    }

    # rescale psiList accordingly
    for(g in seq_len(lavmodel@ngroups)) {
      psiList[[g]] <- ( diag(scale_factor[[g]]) %*% psiList[[g]] %*%
                        diag(scale_factor[[g]]) )
    }

    # put back in GLIST
    GLIST[names(GLIST) == "lambda"] <- lambdaList
    GLIST[names(GLIST) == "psi"]    <- psiList

  } # option 3

  # extract all rotated parameter estimates
  x.rot <- lav_model_get_parameters(lavmodel, GLIST = GLIST, type = type)

  # extra?
  if (extra) {
    attr(x.rot, "extra") <- list(GLIST = GLIST, H = H, lv.order = ORDER)
  }

  # return rotated parameter estimates as a vector
  x.rot
}


# lower-level function, needed for numDeriv
lav_model_efa_rotate_border_x <- function(x, lavmodel = NULL,
                                          lavoptions = NULL,
                                          lavpartable = NULL) {
  # extract rotation options from lavoptions
  method <- lavoptions$rotation
  ropts <- lavoptions$rotation.args
  method.args <- list(
    geomin.epsilon = ropts$geomin.epsilon,
    orthomax.gamma = ropts$orthomax.gamma,
    cf.gamma = ropts$orthomax.gamma,
    oblimin.gamma = ropts$oblimin.gamma,
    promax.kappa = ropts$oblimin.kappa,
    target = ropts$target,
    target.mask = ropts$target.mask
  )

  # place parameters into model matrices
  lavmodel <- lav_model_set_parameters(lavmodel, x = x)

  # GLIST
  GLIST <- lavmodel@GLIST

  # res
  res <- numeric(0L)

  # per group (not per block)
  for (g in seq_len(lavmodel@ngroups)) {

    # group-specific method.args
	this.method.args <- method.args

	# set group-specific target/target.mask (if needed)
    # if target, check target matrix
    if (method == "target.strict" || method == "pst") {
      target <- method.args$target
      if (is.list(target)) {
        this.method.args$target <- target[[g]]
      }
    }
    if (method == "pst") {
      target.mask <- method.args$target.mask
      if (is.list(target.mask)) {
        this.method.args$target.mask <- target.mask[[g]]
      }
    }

    # select model matrices for this group
    mm.in.group <- seq_len(lavmodel@nmat[g]) + cumsum(c(0, lavmodel@nmat))[g]
    MLIST <- GLIST[mm.in.group]

    # reconstruct full LAMBDA (in case of dummy ov's)
    LAMBDA.g <- lav_lisrel_lambda(
      MLIST = MLIST,
      ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
      ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
      ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
      ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]],
      remove.dummy.lv = TRUE
    )
    # reconstruct full THETA (in case of dummy ov's)
    THETA.g <- lav_lisrel_theta(
      MLIST = MLIST,
      ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
      ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
      ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
      ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]]
    )

    # setnames
    set.names <- lav_partable_efa_values(lavpartable)

    # for each set
    for (set in seq_len(lavmodel@nefa)) {
      # check if we have any user=7 elements in this set
      # if not, skip constraints
      ind.idx <- which(lavpartable$op == "=~" &
        lavpartable$group == g &
        lavpartable$efa == set.names[set])
      if (!any(lavpartable$user[ind.idx] == 7L)) {
        next
      }

      # which ov/lv's are involved in this set?
      ov.idx <- lavmodel@ov.efa.idx[[g]][[set]]
      lv.idx <- lavmodel@lv.efa.idx[[g]][[set]]

      # empty set?
      if (length(ov.idx) == 0L) {
        next
      }

      # just 1 factor?
      if (length(lv.idx) < 2L) {
        next
      }

      A <- LAMBDA.g[ov.idx, lv.idx, drop = FALSE]
      P <- nrow(A)
      M <- ncol(A)

      # for oblique, we also need PSI
      if (!ropts$orthogonal) {
        PSI <- MLIST$psi[lv.idx, lv.idx, drop = FALSE]
      }

      # std.ov? we use diagonal of Sigma for this set of ov's only
      if (ropts$std.ov) {
        THETA <- THETA.g[ov.idx, ov.idx, drop = FALSE]
        Sigma <- tcrossprod(A) + THETA
        this.ov.var <- diag(Sigma)
      } else {
        this.ov.var <- rep(1, P)
      }

      # choose method
      method <- tolower(method)
      if (method %in% c(
        "cf-quartimax", "cf-varimax", "cf-equamax",
        "cf-parsimax", "cf-facparsim"
      )) {
        method.fname <- "lav_matrix_rotate_cf"
        this.method.args$cf.gamma <- switch(method,
          "cf-quartimax" = 0,
          "cf-varimax"   = 1 / P,
          "cf-equamax"   = M / (2 * P),
          "cf-parsimax"  = (M - 1) / (P + M - 2),
          "cf-facparsim" = 1
        )
      } else if (method == "target.strict") {
        method.fname <- "lav_matrix_rotate_target"
      } else {
        method.fname <- paste("lav_matrix_rotate_", method, sep = "")
      }

      # check if rotation method exists
      check <- try(get(method.fname), silent = TRUE)
      if (inherits(check, "try-error")) {
        lav_msg_stop(gettextf("unknown rotation method: %s", method.fname))
      }

      # 1. compute row weigths

      # 1.a cov -> cor?
      if (ropts$std.ov) {
        A <- A * 1 / sqrt(this.ov.var)
      }

      if (ropts$row.weights == "none") {
        weights <- rep(1.0, P)
      } else if (ropts$row.weights == "kaiser") {
        weights <- lav_matrix_rotate_kaiser_weights(A)
      } else if (ropts$row.weights == "cureton-mulaik") {
        weights <- lav_matrix_rotate_cm_weights(A)
      } else {
        lav_msg_stop(gettextf("row.weights can be",
          lav_msg_view(c("none", "kaiser", "cureton-mulaik"), "or")))
      }
      A <- A * weights

      # evaluate rotation criterion, extract GRAD
      Q <- do.call(
        method.fname,
        c(list(LAMBDA = A), this.method.args, list(grad = TRUE))
      )
      Gq <- attr(Q, "grad")
      attr(Q, "grad") <- NULL

      # compute 'Z'
      Z <- crossprod(A, Gq)

      # compute constraints
      if (ropts$orthogonal) {
        # the constraint: Z == diagonal
        # or in other words, the non-diagonal elements of
        # Z - t(Z) are all zero
        tmp <- Z - t(Z)
        this.res <- lav_matrix_vech(tmp, diagonal = FALSE)
      } else {
        PSI.z <- PSI * diag(Z) # rescale rows only
        tmp <- Z - PSI.z
        out1 <- lav_matrix_vech(tmp, diagonal = FALSE)
        out2 <- lav_matrix_vechu(tmp, diagonal = FALSE)
        this.res <- c(out1, out2)
      }

      res <- c(res, this.res)
    } # set
  } # group

  # return constraint vector
  res
}

# YR - 26 Nov 2013: generate partable for the unrestricted model
# YR - 19 Mar 2017: handle twolevel model
# YR - 27 May 2021: added lav_partable_unrestricted_chol so we can use
#                   a cholesky parameterization: S = LAMBDA %*% t(LAMBDA)

lav_partable_unrestricted <- function(lavobject = NULL,
                                      # if no object is available,
                                      lavdata = NULL,
                                      lavpta = NULL,
                                      lavoptions = NULL,
                                      lavsamplestats = NULL,
                                      lavh1 = NULL,
                                      # optional user-provided sample stats
                                      sample.cov = NULL,
                                      sample.mean = NULL,
                                      sample.slopes = NULL,
                                      sample.th = NULL,
                                      sample.th.idx = NULL,
                                      sample.cov.x = NULL,
                                      sample.mean.x = NULL) {
  lav_partable_indep_or_unrestricted(
    lavobject = lavobject,
    lavdata = lavdata, lavpta = lavpta, lavoptions = lavoptions,
    lavsamplestats = lavsamplestats, lavh1 = lavh1,
    sample.cov = sample.cov, sample.mean = sample.mean,
    sample.slopes = sample.slopes,
    sample.th = sample.th, sample.th.idx = sample.th.idx,
    independent = FALSE
  )
}

# generate parameter table for an independence model
# YR - 12 Sep 2017: special case of lav_partable_unrestricted()
lav_partable_independence <- function(lavobject = NULL,
                                      # if no object is available,
                                      lavdata = NULL,
                                      lavpta = NULL,
                                      lavoptions = NULL,
                                      lavsamplestats = NULL,
                                      lavh1 = NULL,
                                      # optional user-provided sample stats
                                      sample.cov = NULL,
                                      sample.mean = NULL,
                                      sample.slopes = NULL,
                                      sample.th = NULL,
                                      sample.th.idx = NULL,
                                      sample.cov.x = NULL,
                                      sample.mean.x = NULL) {
  lav_partable_indep_or_unrestricted(
    lavobject = lavobject,
    lavdata = lavdata, lavpta = lavpta, lavoptions = lavoptions,
    lavsamplestats = lavsamplestats, lavh1 = lavh1,
    sample.cov = sample.cov, sample.mean = sample.mean,
    sample.slopes = sample.slopes,
    sample.th = sample.th, sample.th.idx = sample.th.idx,
    independent = TRUE
  )
}

lav_partable_indep_or_unrestricted <- function(lavobject = NULL,
                                               # if no object is available,
                                               lavdata = NULL,
                                               lavpta = NULL,
                                               lavoptions = NULL,
                                               lavsamplestats = NULL,
                                               lavh1 = NULL,
                                               # optional user-provided sample stats
                                               sample.cov = NULL,
                                               sample.mean = NULL,
                                               sample.slopes = NULL,
                                               sample.th = NULL,
                                               sample.th.idx = NULL,
                                               sample.cov.x = NULL,
                                               sample.mean.x = NULL,
                                               independent = FALSE) {
  # grab everything from lavaan lavobject
  if (!is.null(lavobject)) {
    stopifnot(inherits(lavobject, "lavaan"))

    lavdata <- lavobject@Data
    lavoptions <- lavobject@Options
    lavsamplestats <- lavobject@SampleStats
    lavpta <- lavobject@pta
    lavh1 <- lavobject@h1
  }

  if (lavdata@data.type == "none") {
    lavsamplestats <- NULL
  }

  # conditional.x ? check res.cov[[1]] slot
  conditional.x <- FALSE
  if (!is.null(lavsamplestats) && !is.null(lavsamplestats@res.cov[[1]])) {
    conditional.x <- TRUE
  } else if (!is.null(lavoptions) && lavoptions$conditional.x) {
    conditional.x <- TRUE
  }

  # group.w.free?
  group.w.free <- FALSE
  if (!is.null(lavoptions) && lavoptions$group.w.free) {
    group.w.free <- TRUE
  }
  # we use CAPS below for the list version, so we can use 'small caps'
  # within the for() loop

  # get sample statistics, all groups
  SAMPLE.cov <- sample.cov
  if (is.null(SAMPLE.cov) && !is.null(lavsamplestats)) {
    if (conditional.x) {
      SAMPLE.cov <- lavsamplestats@res.cov
    } else {
      SAMPLE.cov <- lavsamplestats@cov
    }
  }

  SAMPLE.mean <- sample.mean
  if (is.null(SAMPLE.mean) && !is.null(lavsamplestats)) {
    if (conditional.x) {
      SAMPLE.mean <- lavsamplestats@res.int
    } else {
      SAMPLE.mean <- lavsamplestats@mean
    }
  }

  SAMPLE.slopes <- sample.slopes
  if (conditional.x && is.null(SAMPLE.slopes) && !is.null(lavsamplestats)) {
    SAMPLE.slopes <- lavsamplestats@res.slopes
  }

  SAMPLE.th <- sample.th
  if (is.null(SAMPLE.th) && !is.null(lavsamplestats)) {
    if (conditional.x) {
      SAMPLE.th <- lavsamplestats@res.th
    } else {
      SAMPLE.th <- lavsamplestats@th
    }
  }

  SAMPLE.th.idx <- sample.th.idx
  if (is.null(SAMPLE.th.idx) && !is.null(lavsamplestats)) {
    SAMPLE.th.idx <- lavsamplestats@th.idx
  }

  SAMPLE.cov.x <- sample.cov.x
  if (is.null(SAMPLE.cov.x) && !is.null(lavsamplestats)) {
    SAMPLE.cov.x <- lavsamplestats@cov.x
  }

  SAMPLE.mean.x <- sample.mean.x
  if (is.null(SAMPLE.mean.x) && !is.null(lavsamplestats)) {
    SAMPLE.mean.x <- lavsamplestats@mean.x
  }



  ov <- lavdata@ov
  meanstructure <- lavoptions$meanstructure
  categorical <- any(ov$type == "ordered")
  ngroups <- lavdata@ngroups
  nlevels <- lavdata@nlevels
  if (lavoptions$estimator == "catML") {
    categorical <- FALSE
  }
  correlation <- FALSE
  if (!is.null(lavoptions$correlation)) {
    correlation <- lavoptions$correlation
  }

  # what with fixed.x?
  # - does not really matter; fit will be saturated anyway
  # - fixed.x = TRUE may avoid convergence issues with non-numeric
  #             x-covariates
  fixed.x <- lavoptions$fixed.x

  # if multilevel
  if (nlevels > 1L) {
    # fixed.x       <- FALSE # for now
    conditional.x <- FALSE # for now
    categorical <- FALSE # for now
  }

  lhs <- rhs <- op <- character(0)
  group <- block <- level <- free <- exo <- integer(0)
  ustart <- numeric(0)

  # block number
  b <- 0L
  for (g in 1:ngroups) {
    # only for multilevel
    if (nlevels > 1L) {
      YLp <- lavsamplestats@YLp[[g]]
      Lp <- lavdata@Lp[[g]]
    }

    # local copy
    sample.cov <- SAMPLE.cov[[g]]
    sample.mean <- SAMPLE.mean[[g]]
    sample.slopes <- SAMPLE.slopes[[g]]
    sample.th <- SAMPLE.th[[g]]
    sample.th.idx <- SAMPLE.th.idx[[g]]
    sample.cov.x <- SAMPLE.cov.x[[g]]
    sample.mean.x <- SAMPLE.mean.x[[g]]

    # force local sample.cov to be pd -- just for starting values anyway
    if (!is.null(sample.cov) && !anyNA(sample.cov)) {
      sample.cov <- lav_matrix_symmetric_force_pd(sample.cov)
    }

    for (l in 1:nlevels) {
      # block
      b <- b + 1L

      # ov.names for this block
      if (is.null(lavpta)) { # only data was used
	    if (nlevels > 1L) {
		  ov.names <- lavdata@ov.names.l[[g]][[(ngroups - 1)*g + b]]
		} else {
          ov.names <- lavdata@ov.names[[g]]
		}
        ov.names.x <- lavdata@ov.names.x[[g]]
        ov.names.nox <- ov.names[!ov.names %in% ov.names.x]
      } else {
        if (conditional.x) {
          ov.names <- lavpta$vnames$ov.nox[[b]]
        } else {
          ov.names <- lavpta$vnames$ov[[b]]
        }
        ov.names.x <- lavpta$vnames$ov.x[[b]]
        ov.names.nox <- lavpta$vnames$ov.nox[[b]]
      }

      # only for multilevel, overwrite sample.cov and sample.mean
      if (nlevels > 1L) {
        if (independent) {
          # beter use lavdata@Lp[[g]]$ov.x.idx??
          # in case we have x/y mismatch across levels?
          ov.x.idx <- lavpta$vidx$ov.x[[b]]
          ov.names.x <- lavpta$vnames$ov.x[[b]]
          ov.names.nox <- lavpta$vnames$ov.nox[[b]]
          sample.cov.x <- lavh1$implied$cov[[b]][ov.x.idx,
            ov.x.idx,
            drop = FALSE
          ]
          sample.mean.x <- lavh1$implied$mean[[b]][ov.x.idx]
        } else {
          ov.names.x <- character(0L)
          ov.names.nox <- ov.names
        }

        if (length(lavh1) > 0L) {
          sample.cov <- lavh1$implied$cov[[b]]
          sample.mean <- lavh1$implied$mean[[b]]
        } else {
          sample.cov <- diag(length(ov.names))
          sample.mean <- numeric(length(ov.names))
        }

        # if(l == 1L) {
        #    sample.cov  <- YLp[[2]]$Sigma.W[block.idx, block.idx,
        #                                    drop = FALSE]
        #    sample.mean <- YLp[[2]]$Mu.W[block.idx]
        # } else {
        #    sample.cov  <- YLp[[2]]$Sigma.B[block.idx, block.idx,
        #                                    drop = FALSE]
        #    sample.mean <- YLp[[2]]$Mu.B[block.idx]
        # }

        # force local sample.cov to be strictly pd (and exaggerate)
        # just for starting values anyway, but at least the first
        # evaluation will be feasible
        sample.cov <- lav_matrix_symmetric_force_pd(sample.cov,
          tol = 1e-03
        )
      }


      # a) VARIANCES (all ov's, if !conditional.x, also exo's)
      nvar <- length(ov.names)

      lhs <- c(lhs, ov.names)
      op <- c(op, rep("~~", nvar))
      rhs <- c(rhs, ov.names)
      block <- c(block, rep(b, nvar))
      group <- c(group, rep(g, nvar))
      level <- c(level, rep(l, nvar))
      if (correlation) {
        free <- c(free, rep(0L, nvar))
      } else {
        free <- c(free, rep(1L, nvar))
      }
      exo <- c(exo, rep(0L, nvar))

      # starting values -- variances
      if (correlation) {
        ustart <- c(ustart, rep(1, nvar))
      } else if (!is.null(sample.cov)) {
        ustart <- c(ustart, diag(sample.cov))
      } else {
        ustart <- c(ustart, rep(as.numeric(NA), nvar))
      }

      # COVARIANCES!
      if (!independent) {
        pstar <- nvar * (nvar - 1) / 2
        if (pstar > 0L) { # only if more than 1 variable
          tmp <- utils::combn(ov.names, 2)
          lhs <- c(lhs, tmp[1, ]) # to fill upper.tri
          op <- c(op, rep("~~", pstar))
          rhs <- c(rhs, tmp[2, ])
          block <- c(block, rep(b, pstar))
          group <- c(group, rep(g, pstar))
          level <- c(level, rep(l, pstar))
          free <- c(free, rep(1L, pstar))
          exo <- c(exo, rep(0L, pstar))
        }

        # starting values -- covariances
        if (!is.null(sample.cov)) {
          sample.cov.vech <- lav_matrix_vech(sample.cov, diagonal = FALSE)
          ustart <- c(ustart, sample.cov.vech)
          # check for 'missing by design' cells: here, the sample.cov
          # element is *exactly* zero (new in 0.6-18)
          zero.cov <- which(sample.cov.vech == 0)
          if (length(zero.cov) > 0L && !is.null(lavh1)) {
            n.tmp <- length(free)
            ones.and.zeroes <- rep(1L, pstar)
            ones.and.zeroes[zero.cov] <- 0L
            free[(n.tmp - pstar + 1):n.tmp] <- ones.and.zeroes
          }
        } else {
          ustart <- c(ustart, rep(as.numeric(NA), pstar))
        }
      }

      # ordered? fix variances, add thresholds
      ord.names <- character(0L)
      if (categorical) {
        ord.names <- ov$name[ov$type == "ordered"]
        # only for this group
        ord.names <- ov.names[which(ov.names %in% ord.names)]

        if (length(ord.names) > 0L) {
          # fix variances to 1.0
          idx <- which(lhs %in% ord.names & op == "~~" & lhs == rhs)
          ustart[idx] <- 1.0
          free[idx] <- 0L

          # add thresholds
          lhs.th <- character(0)
          rhs.th <- character(0)
          for (o in ord.names) {
            nth <- ov$nlev[ov$name == o] - 1L
            if (nth < 1L) next
            lhs.th <- c(lhs.th, rep(o, nth))
            rhs.th <- c(rhs.th, paste("t", seq_len(nth), sep = ""))
          }
          nel <- length(lhs.th)
          lhs <- c(lhs, lhs.th)
          rhs <- c(rhs, rhs.th)
          op <- c(op, rep("|", nel))
          block <- c(block, rep(b, nel))
          group <- c(group, rep(g, nel))
          level <- c(level, rep(l, nel))
          free <- c(free, rep(1L, nel))
          exo <- c(exo, rep(0L, nel))

          # starting values
          if (!is.null(sample.th) && !is.null(sample.th.idx)) {
            th.start <- sample.th[sample.th.idx > 0L]
            ustart <- c(ustart, th.start)
          } else {
            ustart <- c(ustart, rep(as.numeric(NA), nel))
          }

          # fixed-to-zero intercepts (since 0.5.17)
          ov.int <- ord.names
          nel <- length(ov.int)
          lhs <- c(lhs, ov.int)
          op <- c(op, rep("~1", nel))
          rhs <- c(rhs, rep("", nel))
          block <- c(block, rep(b, nel))
          group <- c(group, rep(g, nel))
          level <- c(level, rep(l, nel))
          free <- c(free, rep(0L, nel))
          exo <- c(exo, rep(0L, nel))
          ustart <- c(ustart, rep(0, nel))

          # ~*~ (since 0.6-1)
          nel <- length(ov.int)
          lhs <- c(lhs, ov.int)
          op <- c(op, rep("~*~", nel))
          rhs <- c(rhs, ov.int)
          block <- c(block, rep(b, nel))
          group <- c(group, rep(g, nel))
          level <- c(level, rep(l, nel))
          free <- c(free, rep(0L, nel))
          exo <- c(exo, rep(0L, nel))
          ustart <- c(ustart, rep(1, nel))
        }
      } # categorical

      # correlation structure?
      if (!categorical && correlation) {
        nel <- nvar
        lhs <- c(lhs, ov.names)
        op <- c(op, rep("~*~", nel))
        rhs <- c(rhs, ov.names)
        block <- c(block, rep(b, nel))
        group <- c(group, rep(g, nel))
        level <- c(level, rep(l, nel))
        free <- c(free, rep(0L, nel))
        exo <- c(exo, rep(0L, nel))
        ustart <- c(ustart, rep(1, nel))
      }

      # meanstructure?
      if (meanstructure) {
        # auto-remove ordinal variables
        ov.int <- ov.names
        idx <- which(ov.int %in% ord.names)
        if (length(idx)) ov.int <- ov.int[-idx]

        nel <- length(ov.int)
        lhs <- c(lhs, ov.int)
        op <- c(op, rep("~1", nel))
        rhs <- c(rhs, rep("", nel))
        block <- c(block, rep(b, nel))
        group <- c(group, rep(g, nel))
        level <- c(level, rep(l, nel))
        # if multilevel, level=1 has fixed zeroes
        if (nlevels > 1L && l == 1L) {
          WITHIN <- rep(0L, nel)
          # FIXME: assuming 1 group
          within.idx <- match(Lp$within.idx[[2]], Lp$ov.idx[[1]])
          WITHIN[within.idx] <- 1L
          free <- c(free, WITHIN)
        } else {
          free <- c(free, rep(1L, nel))
        }
        exo <- c(exo, rep(0L, nel))

        # starting values
        if (!is.null(sample.mean)) {
          sample.int.idx <- match(ov.int, ov.names)
          ustart <- c(ustart, sample.mean[sample.int.idx])
        } else {
          ustart <- c(ustart, rep(as.numeric(NA), length(ov.int)))
        }
      }


      # fixed.x exogenous variables?
      if (!conditional.x && (nx <- length(ov.names.x)) > 0L) {
        if (independent && lavoptions$baseline.fixed.x.free.cov) {
          # add covariances for eXo
          pstar <- nx * (nx - 1) / 2
          if (pstar > 0L) { # only if more than 1 variable
            tmp <- utils::combn(ov.names.x, 2)
            lhs <- c(lhs, tmp[1, ]) # to fill upper.tri
            op <- c(op, rep("~~", pstar))
            rhs <- c(rhs, tmp[2, ])
            block <- c(block, rep(b, pstar))
            group <- c(group, rep(g, pstar))
            level <- c(level, rep(l, pstar))
            free <- c(free, rep(1L, pstar))
            exo <- c(exo, rep(0L, pstar))

            # starting values
            if (!is.null(sample.cov.x)) {
              rhs.idx <- match(tmp[1, ], ov.names.x)
              lhs.idx <- match(tmp[2, ], ov.names.x)
              ustart <- c(
                ustart,
                sample.cov.x[cbind(rhs.idx, lhs.idx)]
              )
            } else {
              ustart <- c(ustart, rep(as.numeric(NA), pstar))
            }
          }
        }

        if (fixed.x) {
          # fix variances/covariances
          exo.idx <- which(rhs %in% ov.names.x &
            lhs %in% ov.names.x &
            op == "~~" & group == g) # ok
          exo[exo.idx] <- 1L
          free[exo.idx] <- 0L

          # fix means
          exo.idx <- which(lhs %in% ov.names.x &
            op == "~1" & group == g) # ok
          exo[exo.idx] <- 1L
          free[exo.idx] <- 0L
        }
      }

      # conditional.x?
      if (conditional.x && (nx <- length(ov.names.x)) > 0L) {
        # eXo variances
        nel <- length(ov.names.x)
        lhs <- c(lhs, ov.names.x)
        op <- c(op, rep("~~", nel))
        rhs <- c(rhs, ov.names.x)
        block <- c(block, rep(b, nel))
        group <- c(group, rep(g, nel))
        level <- c(level, rep(l, nel))
        if (fixed.x) {
          free <- c(free, rep(0L, nel))
          exo <- c(exo, rep(1L, nel))
        } else {
          free <- c(free, rep(1L, nel))
          exo <- c(exo, rep(0L, nel))
        }

        # starting values
        if (!is.null(sample.cov.x)) {
          ustart <- c(ustart, diag(sample.cov.x))
        } else {
          ustart <- c(ustart, rep(as.numeric(NA), nel))
        }


        # eXo covariances
        pstar <- nx * (nx - 1) / 2
        if (pstar > 0L) { # only if more than 1 variable
          tmp <- utils::combn(ov.names.x, 2)
          lhs <- c(lhs, tmp[1, ]) # to fill upper.tri
          op <- c(op, rep("~~", pstar))
          rhs <- c(rhs, tmp[2, ])
          block <- c(block, rep(b, pstar))
          group <- c(group, rep(g, pstar))
          level <- c(level, rep(l, pstar))
          if (fixed.x) {
            free <- c(free, rep(0L, pstar))
            exo <- c(exo, rep(1L, pstar))
          } else {
            free <- c(free, rep(1L, pstar))
            exo <- c(exo, rep(0L, pstar))
          }

          # starting values
          if (!is.null(sample.cov.x)) {
            rhs.idx <- match(tmp[1, ], ov.names.x)
            lhs.idx <- match(tmp[2, ], ov.names.x)
            ustart <- c(
              ustart,
              sample.cov.x[cbind(rhs.idx, lhs.idx)]
            )
          } else {
            ustart <- c(ustart, rep(as.numeric(NA), pstar))
          }
        }

        # eXo means
        if (meanstructure) {
          ov.int <- ov.names.x

          nel <- length(ov.int)
          lhs <- c(lhs, ov.int)
          op <- c(op, rep("~1", nel))
          rhs <- c(rhs, rep("", nel))
          group <- c(group, rep(g, nel))
          block <- c(block, rep(b, nel))
          level <- c(level, rep(l, nel))
          if (fixed.x) {
            free <- c(free, rep(0L, nel))
            exo <- c(exo, rep(1L, nel))
          } else {
            free <- c(free, rep(1L, nel))
            exo <- c(exo, rep(0L, nel))
          }

          # starting values
          if (!is.null(sample.mean.x)) {
            sample.int.idx <- match(ov.int, ov.names.x)
            ustart <- c(ustart, sample.mean.x[sample.int.idx])
          } else {
            ustart <- c(ustart, rep(as.numeric(NA), length(ov.int)))
          }
        }

        # slopes
        nnox <- length(ov.names.nox)
        nel <- nnox * nx

        lhs <- c(lhs, rep(ov.names.nox, times = nx))
        op <- c(op, rep("~", nel))
        rhs <- c(rhs, rep(ov.names.x, each = nnox))
        block <- c(block, rep(b, nel))
        group <- c(group, rep(g, nel))
        level <- c(level, rep(l, nel))
        if (independent) {
          if (lavoptions$baseline.conditional.x.free.slopes) {
            free <- c(free, rep(1L, nel))
          } else {
            free <- c(free, rep(0L, nel))
          }
        } else {
          free <- c(free, rep(1L, nel))
        }
        exo <- c(exo, rep(1L, nel))

        # starting values -- slopes
        if (independent) {
          # FIXME: zero slope-structure provides a fit that
          # is equal to the conditional.x = FALSE version;
          # in principle, we could just fix the slope-structure
          # to the sample-based slopes

          # to get the old behaviour:
          if (!lavoptions$baseline.conditional.x.free.slopes) {
            ustart <- c(ustart, rep(0, nel))
          } else {
            # but we probably should do:
            ustart <- c(ustart, lav_matrix_vec(sample.slopes))
          }
        } else if (!is.null(sample.slopes)) {
          ustart <- c(ustart, lav_matrix_vec(sample.slopes))
        } else {
          ustart <- c(ustart, rep(as.numeric(NA), nel))
        }
      } # conditional.x

      # group.w.free (new in 0.6-8)
      if (group.w.free) {
        lhs <- c(lhs, "group")
        op <- c(op, "%")
        rhs <- c(rhs, "w")
        block <- c(block, b)
        group <- c(group, g)
        level <- c(level, l)
        free <- c(free, 1L)
        exo <- c(exo, 0L)
        ustart <- c(ustart, lavsamplestats@WLS.obs[[g]][1])
      }
    } # levels
  } # ngroups

  # free counter
  idx.free <- which(free > 0)
  free[idx.free] <- 1:length(idx.free)

  LIST <- list(
    id = 1:length(lhs),
    lhs = lhs,
    op = op,
    rhs = rhs,
    user = rep(1L, length(lhs)),
    block = block,
    group = group,
    level = level,
    free = free,
    ustart = ustart,
    exo = exo # ,
    # label       = rep("",  length(lhs))
    # eq.id       = rep(0L,  length(lhs)),
    # unco        = free
  )


  # keep level column if no levels? (no for now)
  if (nlevels < 2L) {
    LIST$level <- NULL
  }

  LIST
}

# - currently only used for continuous twolevel data
# - conditional.x not supported (yet)
lav_partable_unrestricted_chol <- function(lavobject = NULL,
                                           # if no object is available,
                                           lavdata = NULL,
                                           lavpta = NULL, # optional
                                           lavoptions = NULL,
                                           group = NULL) {
  # grab everything from lavaan lavobject
  if (!is.null(lavobject)) {
    stopifnot(inherits(lavobject, "lavaan"))

    lavdata <- lavobject@Data
    lavoptions <- lavobject@Options
    # lavsamplestats <- lavobject@SampleStats
    lavpta <- lavobject@pta
    # lavh1 <- lavobject@h1
  }

  ov <- lavdata@ov
  meanstructure <- lavoptions$meanstructure
  categorical <- any(ov$type == "ordered")
  if (categorical) {
    lav_msg_stop(gettext("categorical data not supported in this function"))
  }
  ngroups <- lavdata@ngroups
  nlevels <- lavdata@nlevels

  # select groups
  if (is.null(group)) {
    group.select <- seq_len(ngroups)
  } else {
    stopifnot(is.numeric(group), all(group <= ngroups))
    group.select <- group
    if (length(group.select) == 0L) {
      lav_msg_stop(gettext("no groups selected"))
    }
  }

  # what with fixed.x?
  # - does not really matter; fit will be saturated anyway
  # - fixed.x = TRUE may avoid convergence issues with non-numeric
  #             x-covariates
  fixed.x <- lavoptions$fixed.x

  # if multilevel
  if (nlevels > 1L) {
    # fixed.x       <- FALSE # for now
    conditional.x <- FALSE # for now
    categorical <- FALSE # for now
  }

  lhs <- rhs <- op <- character(0)
  group <- block <- level <- free <- exo <- integer(0)
  ustart <- lower <- numeric(0)

  # block number
  b <- 0L
  for (g in 1:ngroups) {

    # select group?
    if (! g %in% group.select) {
      next
    }

    # only for multilevel
    if (nlevels > 1L) {
      Lp <- lavdata@Lp[[g]]
    }

    for (l in 1:nlevels) {
      # block
      b <- b + 1L

      if (is.null(lavpta)) {
        ov.names <- lavdata@ov.names[[b]]
        ov.names.x <- lavdata@ov.names.x[[b]]
        ov.names.nox <- ov.names[!ov.names %in% ov.names.x]
      } else {
        ov.names <- lavpta$vnames$ov[[b]]
        ov.names.x <- lavpta$vnames$ov.x[[b]]
        ov.names.nox <- lavpta$vnames$ov.nox[[b]]
      }

      # only for multilevel, overwrite sample.cov and sample.mean
      if (nlevels > 1L) {
        ov.names.x <- character(0L)
        ov.names.nox <- ov.names
      }

      # create lv.names == ov.names
      lv.names <- paste("f", ov.names, sep = "")

      # a) OV VARIANCES -> fixed to zero
      nvar <- length(ov.names)
      lhs <- c(lhs, ov.names)
      op <- c(op, rep("~~", nvar))
      rhs <- c(rhs, ov.names)
      block <- c(block, rep(b, nvar))
      group <- c(group, rep(g, nvar))
      level <- c(level, rep(l, nvar))
      ustart <- c(ustart, rep(0.0001, nvar)) ### Force PD!! (option?)
      free <- c(free, rep(0L, nvar))
      exo <- c(exo, rep(0L, nvar))
      lower <- c(lower, rep(0.0, nvar))

      # b) LV VARIANCES -> fixed to 1.0
      nvar <- length(lv.names)
      lhs <- c(lhs, lv.names)
      op <- c(op, rep("~~", nvar))
      rhs <- c(rhs, lv.names)
      block <- c(block, rep(b, nvar))
      group <- c(group, rep(g, nvar))
      level <- c(level, rep(l, nvar))
      ustart <- c(ustart, rep(1.0, nvar))
      free <- c(free, rep(0L, nvar))
      exo <- c(exo, rep(0L, nvar))
      lower <- c(lower, rep(1.0, nvar))

      # c) LOADINGS self
      nvar <- length(ov.names)
      lhs <- c(lhs, lv.names)
      op <- c(op, rep("=~", nvar))
      rhs <- c(rhs, ov.names)
      block <- c(block, rep(b, nvar))
      group <- c(group, rep(g, nvar))
      level <- c(level, rep(l, nvar))
      ustart <- c(ustart, rep(as.numeric(NA), nvar))
      free <- c(free, rep(1L, nvar))
      exo <- c(exo, rep(0L, nvar))
      lower <- c(lower, rep(0.0, nvar)) # lower bound!

      # d) LOADINGS other
      if (length(ov.names) > 1L) {
        tmp <- utils::combn(ov.names, 2)
        pstar <- ncol(tmp)
        lhs <- c(lhs, paste("f", tmp[1, ], sep = ""))
        op <- c(op, rep("=~", pstar))
        rhs <- c(rhs, tmp[2, ])
        block <- c(block, rep(b, pstar))
        group <- c(group, rep(g, pstar))
        level <- c(level, rep(l, pstar))
        free <- c(free, rep(1L, pstar))
        exo <- c(exo, rep(0L, pstar))
        lower <- c(lower, rep(-Inf, pstar))
        ustart <- c(ustart, rep(as.numeric(NA), pstar))
      }

      # check for zero coverage at level 1 (new in 0.6-18)
      if (lavdata@missing == "ml" && l == 1 && !is.null(lavdata@Mp[[g]])) {
        coverage <- lavdata@Mp[[g]]$coverage
        sample.cov.vech <- lav_matrix_vech(coverage, diagonal = FALSE)
        zero.cov <- which(sample.cov.vech == 0)
        if (length(zero.cov) > 0L) {
          n.tmp <- length(free)
          ones.and.zeroes <- rep(1L, pstar)
          ones.and.zeroes[zero.cov] <- 0L
		  inf.and.zeroes <- rep(-Inf, pstar)
		  inf.and.zeroes[zero.cov] <- 0
		  na.and.zeroes <- rep(as.numeric(NA), pstar)
		  na.and.zeroes[zero.cov] <- 0
          free[  (n.tmp - pstar + 1):n.tmp] <- ones.and.zeroes
		  ustart[(n.tmp - pstar + 1):n.tmp] <- na.and.zeroes
		  lower[ (n.tmp - pstar + 1):n.tmp] <- inf.and.zeroes
        }
      }

      # meanstructure?
      if (meanstructure) {
        # OV
        ov.int <- ov.names

        nel <- length(ov.int)
        lhs <- c(lhs, ov.int)
        op <- c(op, rep("~1", nel))
        rhs <- c(rhs, rep("", nel))
        block <- c(block, rep(b, nel))
        group <- c(group, rep(g, nel))
        level <- c(level, rep(l, nel))
        # if multilevel, level=1 has fixed zeroes
        if (nlevels > 1L && l == 1L) {
          WITHIN <- rep(0L, nel)
          within.idx <- match(Lp$within.idx[[2]], Lp$ov.idx[[1]])
          WITHIN[within.idx] <- 1L
          free <- c(free, WITHIN)
        } else {
          free <- c(free, rep(1L, nel))
        }
        exo <- c(exo, rep(0L, nel))
        lower <- c(lower, rep(-Inf, nel))
        ustart <- c(ustart, rep(as.numeric(NA), nel))

        # LV
        ov.int <- lv.names

        nel <- length(ov.int)
        lhs <- c(lhs, ov.int)
        op <- c(op, rep("~1", nel))
        rhs <- c(rhs, rep("", nel))
        block <- c(block, rep(b, nel))
        group <- c(group, rep(g, nel))
        level <- c(level, rep(l, nel))
        free <- c(free, rep(0L, nel))
        exo <- c(exo, rep(0L, nel))
        ustart <- c(ustart, rep(0.0, nel))
        lower <- c(lower, rep(-Inf, nel))
      }
    } # levels
  } # ngroups

  # free counter
  idx.free <- which(free > 0)
  free[idx.free] <- 1:length(idx.free)

  LIST <- list(
    id = 1:length(lhs),
    lhs = lhs,
    op = op,
    rhs = rhs,
    user = rep(1L, length(lhs)),
    block = block,
    group = group,
    level = level,
    free = free,
    ustart = ustart,
    exo = exo,
    lower = lower # ,
    # label       = rep("",  length(lhs))
    # eq.id       = rep(0L,  length(lhs)),
    # unco        = free
  )


  # keep level column if no levels? (no for now)
  if (nlevels < 2L) {
    LIST$level <- NULL
  }

  LIST
}

# create a 'baseline' model from an existing object/partable
# - fix all (free) directed effects (factor loadings, regressions) to zero
# - fix all (free) covariances to zero
# - neutralize the (measured) latent variables by fixing their variances
#   to zero
# - keep all other (relevant) constraints
# - this *should* result in a baseline model that is always nested within
#   the original model
lav_partable_baseline <- function(lavobject = NULL,
                                  # if no object is available,
                                  lavpartable = NULL,
                                  lavh1 = NULL) {

  # grab everything from lavaan lavobject
  if (!is.null(lavobject)) {
    stopifnot(inherits(lavobject, "lavaan"))
    lavpartable <- lavobject@ParTable
    lavh1 <- lavobject@h1
  }

  # number of blocks
  nblocks <- lav_partable_nblocks(lavpartable)

  # conditional.x ? check res.cov[[1]] slot
  conditional.x <- FALSE
  if (!is.null(lavh1) && !is.null(lavh1$implied$res.cov[[1]])) {
    conditional.x <- TRUE
  }

  # get sample statistics, all groups
  if (conditional.x) {
    sample.cov <- lavh1$implied$res.cov
    sample.mean <- lavh1$implied$res.int
  } else {
    sample.cov <- lavh1$implied$cov
    sample.mean <- lavh1$implied$mean
  }

  # shortcut of lavpartable
  PT <- lavpartable

  # keep exo=1 starting values
  exo.idx <- which(PT$exo == 1L)
  if (!is.null(PT$est)) {
    PT$ustart[exo.idx] <- PT$est[exo.idx]
  } else if (!is.null(PT$start)) {
    PT$iustart[exo.idx] <- PT$start[exo.idx]
  }

  # remove est/se columns, if present, but keep start column
  PT$est <- PT$se <- NULL

  # lv.names
  lv.names <- lav_partable_vnames(PT, "lv")

  # zero-out all directed effects and covariances
  directed.idx <- which(PT$op %in% c("=~", "~") & PT$free > 0L & PT$exo != 1L)
  cov.idx <- which(PT$op == "~~" & PT$lhs != PT$rhs & PT$free > 0L)

  # neutralize latent variables
  lv.var.idx <- which(PT$op == "~~" & PT$lhs %in% lv.names & PT$lhs == PT$rhs &
                      PT$free > 0L)
  #lv.int.idx <- which(PT$op == "~1" & PT$lhs %in% lv.names & PT$free > 0L)
  #zero.idx <- c(directed.idx, cov.idx, lv.var.idx, lv.int.idx)
  zero.idx <- c(directed.idx, cov.idx, lv.var.idx)

  PT$free[zero.idx] <- 0L
  PT$start[zero.idx] <- 0
  PT$ustart[zero.idx] <- 0

  # Question: fill in more elements in PT$start? (only ov variances for now)
  for (b in seq_len(nblocks)) {
    ov.names.num <- lav_partable_vnames(lavpartable, "ov.num", block = b)
    if (conditional.x) {
      ov.names.x <- lav_partable_vnames(lavpartable, "ov.x", block = b)
      ov.names.num <- ov.names.num[!ov.names.num %in% ov.names.x]
    }
    ovar.idx <- which(lavpartable$block == b &
      lavpartable$op == "~~" &
      lavpartable$lhs %in% ov.names.num &
      lavpartable$lhs == lavpartable$rhs)
    sample.var.idx <- match(lavpartable$lhs[ovar.idx], ov.names.num)
    PT$ustart[ovar.idx] <- diag(sample.cov[[b]])[sample.var.idx]
  }

  PT <- lav_partable_complete(PT)
  PT
}

## NOTE:
## round(1.2355, 3) = 1.236
## but
## round(1.2345, 3) = 1.234
##
## perhaps we should add 0.0005 or something to avoid this?

lav_dataframe_print <- function(x, ..., nd = 3L) {
  ROW.NAMES <- rownames(x)
  y <- as.data.frame(lapply(x, function(x) {
    if (is.numeric(x)) round(x, nd) else x
  }))
  rownames(y) <- ROW.NAMES

  if (!is.null(attr(x, "header"))) {
    cat("\n", attr(x, "header"), "\n\n", sep = "")
  }

  print(y, ...)

  if (!is.null(attr(x, "footer"))) {
    cat("\n", attr(x, "footer"), "\n\n", sep = "")
  }

  invisible(x)
}

lav_lavaanlist_print <- function(x, ...) {
  y <- unclass(x)
  attr(y, "header") <- NULL

  header <- attr(x, "header")
  if (!is.null(header)) {
    if (is.character(header)) {
      cat("\n", header, "\n\n", sep = "")
    } else {
      print(header)
      cat("\n")
    }
  }

  print(y, ...)
  invisible(x)
}


# prints only lower triangle of a symmetric matrix
lav_matrix_symmetric_print <- function(x, ..., nd = 3L, shift = 0L,
                                          diag.na.dot = TRUE) {
  # print only lower triangle of a symmetric matrix
  # this function was inspired by the `print.correlation' function
  # in package nlme
  x <- as.matrix(x) # just in case
  y <- x
  y <- unclass(y)
  attributes(y)[c("header", "footer")] <- NULL
  ll <- lower.tri(x, diag = TRUE)
  y[ll] <- format(round(x[ll], digits = nd))
  y[!ll] <- ""
  if (diag.na.dot) {
    # print a "." instead of NA on the main diagonal (eg lav_efalist_summary)
    diag.idx <- lav_matrix_diag_idx(ncol(x))
    tmp <- x[diag.idx]
    if (all(is.na(tmp))) {
      y[diag.idx] <- paste(strrep(" ", nd + 2L), ".", sep = "")
    }
  }
  if (!is.null(colnames(x))) {
    colnames(y) <- abbreviate(colnames(x), minlength = nd + 3L)
  }
  if (shift > 0L) {
    empty.string <- rep(strrep(x = " ", times = shift), times = nrow(x))
    if (!is.null(rownames(x))) {
      rownames(y) <- paste(empty.string, rownames(x), sep = "")
    } else {
      rownames(y) <- empty.string
    }
  }

  if (!is.null(attr(x, "header"))) {
    cat("\n", attr(x, "header"), "\n\n", sep = "")
  }

  print(y, ..., quote = FALSE, right = TRUE)

  if (!is.null(attr(x, "footer"))) {
    cat("\n", attr(x, "footer"), "\n\n", sep = "")
  }

  invisible(x)
}


lav_matrix_print <- function(x, ..., nd = 3L, shift = 0L) {
  x <- as.matrix(x) # just in case
  y <- unclass(x)
  attributes(y)[c("header", "footer")] <- NULL
  if (!is.null(colnames(x))) {
    colnames(y) <- abbreviate(colnames(x), minlength = nd + 3L)
  }
  if (shift > 0L) {
    empty.string <- rep(strrep(x = " ", times = shift), times = nrow(x))
    if (!is.null(rownames(x))) {
      rownames(y) <- paste(empty.string, rownames(x), sep = "")
    } else {
      rownames(y) <- empty.string
    }
  }
  if (!is.null(attr(x, "header"))) {
    cat("\n", attr(x, "header"), "\n\n", sep = "")
  }

  print(round(y, nd), right = TRUE, ...)

  if (!is.null(attr(x, "footer"))) {
    cat("\n", attr(x, "footer"), "\n\n", sep = "")
  }

  invisible(x)
}

lav_vector_print <- function(x, ..., nd = 3L, shift = 0L) {
  y <- unclass(x)
  attributes(y)[c("header", "footer")] <- NULL
  # if(!is.null(names(x))) {
  #    names(y) <- abbreviate(names(x), minlength = nd + 3)
  # }
  if (!is.null(attr(x, "header"))) {
    cat("\n", attr(x, "header"), "\n\n", sep = "")
  }

  if (shift > 0L) {
    empty.string <- strrep(x = " ", times = shift)
    tmp <- format(y, digits = nd, width = 2L + nd)
    tmp[1] <- paste(empty.string, tmp[1], sep = "")
    print(tmp, quote = FALSE, ...)
  } else {
    print(round(y, nd), right = TRUE, ...)
  }

  if (!is.null(attr(x, "footer"))) {
    cat("\n", attr(x, "footer"), "\n\n", sep = "")
  }

  invisible(x)
}

print.lavaan.character <- function(x, ...) {
  cat(x)
  invisible(x)
}

lav_parameterestimates_print <- function(x, ..., nd = 3L) {
  # format for numeric values
  num.format <- paste("%", max(8L, nd + 5L), ".", nd, "f", sep = "")
  int.format <- paste("%", max(8L, nd + 5L), "d", sep = "")
  char.format <- paste("%", max(8L, nd + 5L), "s", sep = "")

  # output sections
  GSECTIONS <- c(
    "Latent Variables",
    "Composites",
    "Regressions",
    "Covariances",
    "Intercepts",
    "Thresholds",
    "Variances",
    "Scales y*",
    "Group Weight",
    "R-Square"
  )
  ASECTIONS <- c(
    "Defined Parameters",
    "Constraints"
  )

  # header?
  header <- attr(x, "header")
  if (is.null(header)) {
    header <- FALSE
  }

  if (header) {
    cat("\nParameter Estimates:\n\n")

    # info about parameterization (if categorical only)
    categorical.flag <- attr(x, "categorical")
    if (categorical.flag) {
      # container
      c1 <- c2 <- character(0L)

      # which parameterization?
      c1 <- c(c1, "Parameterization")
      tmp.txt <- attr(x, "parameterization")
      c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
        substring(tmp.txt, 2),
        sep = ""
      ))

      # format c1/c2
      c1 <- format(c1, width = 37L)
      c2 <- format(c2,
        width = 14L + max(0, (nd - 3L)) * 4L, justify = "right"
      )

      # create character matrix
      M <- cbind(c1, c2, deparse.level = 0)
      colnames(M) <- rep("", ncol(M))
      rownames(M) <- rep(" ", nrow(M))

      # print
      write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
    }

    # info about standard errors (if we have x$se only)
    # 1. information
    # 2. se
    # 3. bootstrap requested/successful draws
    if (!is.null(x$se)) {
      # container
      c1 <- c2 <- character(0L)

      # which type of standard errors?
      c1 <- c(c1, "Standard errors")
      if (attr(x, "se") == "robust.huber.white") {
        tmp.txt <- "sandwich" # since 0.6-6
      } else {
        tmp.txt <- attr(x, "se")
      }
      c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
        substring(tmp.txt, 2),
        sep = ""
      ))
      # information
      if (attr(x, "se") != "bootstrap") {
        # type for information
        if (attr(x, "se") == "robust.huber.white") {
          c1 <- c(c1, "Information bread")
        } else {
          c1 <- c(c1, "Information")
        }
        tmp.txt <- attr(x, "information")
        c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
          substring(tmp.txt, 2),
          sep = ""
        ))

        # if observed, which type? (hessian of h1)
        if (attr(x, "information") == "observed") {
          c1 <- c(c1, "Observed information based on")
          tmp.txt <- attr(x, "observed.information")
          c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
            substring(tmp.txt, 2),
            sep = ""
          ))
        }

        # if h1 is involved, structured or unstructured?
        if (attr(x, "information") %in% c("expected", "first.order") ||
          attr(x, "observed.information") == "h1") {
          if (attr(x, "se") == "robust.huber.white" &&
            attr(x, "h1.information") !=
              attr(x, "h1.information.meat")) {
            c1 <- c(c1, "Information bread saturated (h1) model")
          } else {
            c1 <- c(c1, "Information saturated (h1) model")
          }
          tmp.txt <- attr(x, "h1.information")
          c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
            substring(tmp.txt, 2),
            sep = ""
          ))
        }

        # if sandwich, which information for the meat? (first.order)
        # only print if it is NOT first.order
        if (attr(x, "se") == "robust.huber.white" &&
          attr(x, "information.meat") != "first.order") {
          c1 <- c(c1, "Information meat")
          tmp.txt <- attr(x, "information.meat")
          c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
            substring(tmp.txt, 2),
            sep = ""
          ))
        }

        # if sandwich, structured or unstructured for the meat?
        # only print if it is not the same as h1.information
        if (attr(x, "se") == "robust.huber.white" &&
          attr(x, "h1.information.meat") !=
            attr(x, "h1.information")) {
          c1 <- c(c1, "Information meat saturated (h1) model")
          tmp.txt <- attr(x, "h1.information.meat")
          c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
            substring(tmp.txt, 2),
            sep = ""
          ))
        }
      } # no bootstrap

      #TDJ: Pooling options for lavaan.mi-class objects (which NEVER bootstrap)
      if (isTRUE(attr(x, "pooled"))) {
        ## add an empty element for a space before pooling section
        c1 <- c(c1, "", "Pooled across imputations")
        c2 <- c(c2, "", "Rubin's (1987) rules")
      }
      if (!is.null(attr(x, "scale.W"))) {
        c1 <- c(c1, "Augment within-imputation variance")
        if (attr(x, "scale.W")) {
          c2 <- c(c2, "Scale by average RIV")
        } else {
          c2 <- c(c2, "Add between component")
        }
      }
      if (!is.null(attr(x, "asymptotic"))) {
        c1 <- c(c1, "Wald test for pooled parameters")
        if (attr(x, "asymptotic")) {
          c2 <- c(c2, "Normal (z) distribution")
        } else {
          c2 <- c(c2, "t(df) distribution")
        }
      }

      # 4.
      if (attr(x, "se") == "bootstrap" && !is.null(attr(x, "bootstrap"))) {
        c1 <- c(c1, "Number of requested bootstrap draws")
        c2 <- c(c2, attr(x, "bootstrap"))
        c1 <- c(c1, "Number of successful bootstrap draws")
        c2 <- c(c2, attr(x, "bootstrap.successful"))
      }

      # format c1/c2
      c1 <- format(c1, width = 37L)
      c2 <- format(c2,
        width = 14L + max(0, (nd - 3L)) * 4L, justify = "right"
      )

      # create character matrix
      M <- cbind(c1, c2, deparse.level = 0)
      colnames(M) <- rep("", ncol(M))
      rownames(M) <- rep(" ", nrow(M))

      # print
      write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)

      #TDJ: Message for lavaan.mi-class objects when df > 1000 for t test
      if (isTRUE(attr(x, "infDF"))) {
        cat(c("\n  Pooled t statistics with df >= 1000 are displayed with",
              "\n  df = Inf(inity) to save space. Although the t distribution",
              "\n  with large df closely approximates a standard normal",
              "\n  distribution, exact df for reporting these t tests can be",
              "\n  obtained from parameterEstimates.mi() \n\n"), sep = "")
      }

    }
  }

  # number of groups
  if (is.null(x$group)) {
    ngroups <- 1L
    x$group <- rep(1L, length(x$lhs))
  } else {
    ngroups <- lav_partable_ngroups(x)
  }

  # number of levels
  if (is.null(x$level)) {
    nlevels <- 1L
    x$level <- rep(1L, length(x$lhs))
  } else {
    nlevels <- lav_partable_nlevels(x)
  }

  # block column
  if (is.null(x$block)) {
    x$block <- rep(1L, length(x$lhs))
  }

  # step column (SAM)
  # if(!is.null(x$step)) {
  #    tmp.LABEL <- rep("", length(x$lhs))
  #    p1.idx <- which(x$step == 1L)
  #    p2.idx <- which(x$step == 2L)
  #    tmp.LABEL[p1.idx] <- "1"
  #    tmp.LABEL[p2.idx] <- "2"
  #
  #    if(is.null(x$label)) {
  #        x$label <- tmp.LABEL
  #    } else {
  #        x$label <- paste(x$label, tmp.LABEL, sep = "")
  #    }
  #
  #    x$step <- NULL
  # }

  # round to 3 digits after the decimal point
  y <- as.data.frame(
    lapply(x, function(x) {
      if (is.integer(x)) {
        sprintf(int.format, x)
      } else if (is.character(x)) { # perhaps plabel
        sprintf(char.format, x)
      } else if (is.numeric(x)) {
        sprintf(num.format, x)
      } else {
        x
      }
    }),
    stringsAsFactors = FALSE
  )

  # always remove /block/level/group/op/rhs/label/exo columns
  y$op <- y$group <- y$rhs <- y$label <- y$exo <- NULL
  y$block <- y$level <- NULL
  y$efa <- NULL

  # if standardized, remove std.nox column (space reasons only)
  # unless, std.all is already removed
  if (!is.null(y$std.all)) {
    y$std.nox <- NULL
  }

  # convert to character matrix
  m <- as.matrix(format.data.frame(y,
    na.encode = FALSE,
    justify = "right"
  ))

  # use empty row names
  rownames(m) <- rep("", nrow(m))

  # handle se == 0.0
  if (!is.null(x$se)) {
    se.idx <- which(x$se == 0)
    if (length(se.idx) > 0L) {
      m[se.idx, "se"] <- ""
      if (!is.null(x$z)) {
        m[se.idx, "z"] <- ""
      }
      if (!is.null(x$pvalue)) {
        m[se.idx, "pvalue"] <- ""
      }
      ## for lavaan.mi-class objects (semTools)
      if (!is.null(x$t)) {
        m[se.idx, "t"] <- ""
      }
      if (!is.null(x$df)) {
        m[se.idx, "df"] <- ""
      }
    }

    # handle se == NA
    se.idx <- which(is.na(x$se))
    if (length(se.idx) > 0L) {
      if (!is.null(x$z)) {
        m[se.idx, "z"] <- ""
      }
      if (!is.null(x$pvalue)) {
        m[se.idx, "pvalue"] <- ""
      }
      ## for lavaan.mi-class objects (semTools)
      if (!is.null(x$t)) {
        m[se.idx, "t"] <- ""
      }
      if (!is.null(x$df)) {
        m[se.idx, "df"] <- ""
      }
    }
  }

  # handle lower/upper boundary points
  if (!is.null(x$lower)) {
    b.idx <- which(abs(x$lower - x$est) < sqrt(.Machine$double.eps) &
      (is.na(x$se) | (is.finite(x$se) & x$se != 0.0)))
    if (length(b.idx) > 0L && !is.null(x$pvalue)) {
      m[b.idx, "pvalue"] <- ""
      if (is.null(x$label)) {
        x$label <- rep("", length(x$lhs))
      }
      x$label[b.idx] <- ifelse(nchar(x$label[b.idx]) > 0L,
        paste(x$label[b.idx], "+lb", sep = ""),
        "lb"
      )
    }
    # remove lower column
    m <- m[, colnames(m) != "lower"]
  }
  if (!is.null(x$upper)) {
    b.idx <- which(abs(x$upper - x$est) < sqrt(.Machine$double.eps) &
      is.finite(x$se) & x$se != 0.0)
    if (length(b.idx) > 0L && !is.null(x$pvalue)) {
      m[b.idx, "pvalue"] <- ""
      if (is.null(x$label)) {
        x$label <- rep("", length(x$lhs))
      }
      x$label[b.idx] <- ifelse(nchar(x$label[b.idx]) > 0L,
        paste(x$label[b.idx], "+ub", sep = ""),
        "ub"
      )
    }
    # remove upper column
    m <- m[, colnames(m) != "upper"]
  }


  # handle fmi
  if (!is.null(x$fmi)) {
    se.idx <- which(x$se == 0)
    if (length(se.idx) > 0L) {
      m[se.idx, "fmi"] <- ""
      ## for lavaan.mi-class objects (semTools)
      if (!is.null(x$riv)) m[se.idx, "riv"] <- ""
    }

    not.idx <- which(x$op %in% c(":=", "<", ">", "=="))
    if (length(not.idx) > 0L) {
      if (!is.null(x$fmi)) {
        m[not.idx, "fmi"] <- ""
        ## for lavaan.mi-class objects (semTools)
        if (!is.null(x$riv)) m[not.idx, "riv"] <- ""
      }
    }
  }

  # for blavaan, handle Post.SD and PSRF
  if (!is.null(x$Post.SD)) {
    se.idx <- which(x$Post.SD == 0)
    if (length(se.idx) > 0L) {
      m[se.idx, "Post.SD"] <- ""
      if (!is.null(x$psrf)) {
        m[se.idx, "psrf"] <- ""
      }
      if (!is.null(x$PSRF)) {
        m[se.idx, "PSRF"] <- ""
      }
    }

    # handle psrf for defined parameters
    not.idx <- which(x$op %in% c(":=", "<", ">", "=="))
    if (length(not.idx) > 0L) {
      if (!is.null(x$psrf)) {
        m[not.idx, "psrf"] <- ""
      }
      if (!is.null(x$PSRF)) {
        m[not.idx, "PSRF"] <- ""
      }
    }
  }

  # rename some column names
  colnames(m)[colnames(m) == "lhs"] <- ""
  colnames(m)[colnames(m) == "op"] <- ""
  colnames(m)[colnames(m) == "rhs"] <- ""
  colnames(m)[colnames(m) == "step"] <- "Step"
  colnames(m)[colnames(m) == "est"] <- "Estimate"
  colnames(m)[colnames(m) == "se"] <- "Std.Err"
  colnames(m)[colnames(m) == "z"] <- "z-value"
  colnames(m)[colnames(m) == "pvalue"] <- "P(>|z|)"
  colnames(m)[colnames(m) == "std.lv"] <- "Std.lv"
  colnames(m)[colnames(m) == "std.all"] <- "Std.all"
  colnames(m)[colnames(m) == "std.nox"] <- "Std.nox"
  colnames(m)[colnames(m) == "prior"] <- "Prior"
  colnames(m)[colnames(m) == "fmi"] <- "FMI"
  ## for lavaan.mi-class objects (semTools)
  if ("t" %in% colnames(m)) {
    colnames(m)[colnames(m) == "t"] <- "t-value"
    colnames(m)[colnames(m) == "P(>|z|)"] <- "P(>|t|)"
    colnames(m)[colnames(m) == "riv"] <- "RIV"
  }

  # format column names
  colnames(m) <- sprintf(char.format, colnames(m))

  # exceptions for blavaan: Post.Mean (width = 9), Prior (width = 14)
  if (!is.null(x$Post.Mean)) {
    tmp <- gsub("[ \t]+", "", colnames(m), perl = TRUE)

    # reformat "Post.Mean" column
    col.idx <- which(tmp == "Post.Mean")
    if (length(col.idx) > 0L) {
      tmp.format <- paste("%", max(9, nd + 5), "s", sep = "")
      colnames(m)[col.idx] <- sprintf(tmp.format, colnames(m)[col.idx])
      m[, col.idx] <- sprintf(tmp.format, m[, col.idx])
    }

    # reformat "Prior" column
    col.idx <- which(tmp == "Prior")
    if (length(col.idx) > 0L) {
      MAX <- max(nchar(m[, col.idx])) + 1L
      tmp.format <- paste("%", max(MAX, nd + 5), "s", sep = "")
      colnames(m)[col.idx] <- sprintf(tmp.format, colnames(m)[col.idx])
      m[, col.idx] <- sprintf(tmp.format, m[, col.idx])
    }
  }

  b <- 0L
  # group-specific sections
  for (g in 1:ngroups) {
    # group header
    if (ngroups > 1L) {
      group.label <- attr(x, "group.label")
      cat("\n\n")
      cat("Group ", g, " [", group.label[g], "]:\n", sep = "")
    }

    for (l in 1:nlevels) {
      # block number
      b <- b + 1L

      # ov/lv names
      ov.names <- lav_object_vnames(x, "ov", block = b)
      lv.names <- lav_object_vnames(x, "lv", block = b)

      # level header
      if (nlevels > 1L) {
        level.label <- attr(x, "level.label")
        cat("\n\n")
        cat("Level ", l, " [", level.label[l], "]:\n", sep = "")
      }

      # group-specific sections
      for (s in GSECTIONS) {
        if (s == "Latent Variables") {
          row.idx <- which(x$op == "=~" & !x$lhs %in% ov.names &
            x$block == b)
          if (length(row.idx) == 0L) next
          m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx])
        } else if (s == "Composites") {
          row.idx <- which(x$op == "<~" & x$block == b)
          if (length(row.idx) == 0L) next
          m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx])
        } else if (s == "Regressions") {
          row.idx <- which(x$op == "~" & x$block == b)
          if (length(row.idx) == 0L) next
          m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx])
        } else if (s == "Covariances") {
          row.idx <- which(x$op == "~~" & x$lhs != x$rhs & !x$exo &
            x$block == b)
          if (length(row.idx) == 0L) next
          # make distinction between residual and plain
          y.names <- unique(c(
            lav_object_vnames(x, "eqs.y"),
            lav_object_vnames(x, "ov.ind"),
            lav_object_vnames(x, "lv.ind")
          ))
          PREFIX <- rep("", length(row.idx))
          PREFIX[x$rhs[row.idx] %in% y.names] <- "  ."
          m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx],
            PREFIX = PREFIX
          )
          # m[row.idx,1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx])
        } else if (s == "Intercepts") {
          row.idx <- which(x$op == "~1" & !x$exo & x$block == b)
          if (length(row.idx) == 0L) next
          # make distinction between intercepts and means
          y.names <- unique(c(
            lav_object_vnames(x, "eqs.y"),
            lav_object_vnames(x, "ov.ind"),
            lav_object_vnames(x, "lv.ind")
          ))
          PREFIX <- rep("", length(row.idx))
          PREFIX[x$lhs[row.idx] %in% y.names] <- "  ."
          m[row.idx, 1] <- lav_print_format_names(x$lhs[row.idx], x$label[row.idx],
            PREFIX = PREFIX
          )
          # m[row.idx,1] <- lav_print_format_names(x$lhs[row.idx], x$label[row.idx])
        } else if (s == "Thresholds") {
          row.idx <- which(x$op == "|" & x$block == b)
          if (length(row.idx) == 0L) next
          m[row.idx, 1] <- lav_print_format_names(paste(x$lhs[row.idx], "|",
            x$rhs[row.idx],
            sep = ""
          ), x$label[row.idx])
        } else if (s == "Variances") {
          row.idx <- which(x$op == "~~" & x$lhs == x$rhs & !x$exo &
            x$block == b)
          if (length(row.idx) == 0L) next
          # make distinction between residual and plain
          y.names <- unique(c(
            lav_object_vnames(x, "eqs.y"),
            lav_object_vnames(x, "ov.ind"),
            lav_object_vnames(x, "lv.ind")
          ))
          PREFIX <- rep("", length(row.idx))
          PREFIX[x$rhs[row.idx] %in% y.names] <- "  ."
          m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx],
            PREFIX = PREFIX
          )
        } else if (s == "Scales y*") {
          row.idx <- which(x$op == "~*~" & x$block == b)
          if (length(row.idx) == 0L) next
          m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx])
        } else if (s == "Group Weight") {
          row.idx <- which(x$lhs == "group" & x$op == "%" & x$block == b)
          if (length(row.idx) == 0L) next
          m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx])
        } else if (s == "R-Square") {
          row.idx <- which(x$op == "r2" & x$block == b)
          if (length(row.idx) == 0L) next
          m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx])
        } else {
          row.idx <- integer(0L)
        }

        # do we need special formatting for this section?
        # three types:
        #  - regular (nothing to do, except row/colnames)
        #  - R-square
        #  - Latent Variables (and Composites), Regressions and Covariances
        #    'bundle' the output per lhs element

        # bundling
        if (s %in% c(
          "Latent Variables", "Composites",
          "Regressions", "Covariances"
        )) {
          nel <- length(row.idx)
          M <- matrix("", nrow = nel * 2, ncol = ncol(m))
          colnames(M) <- colnames(m)
          rownames(M) <- rep("", NROW(M))
          # colnames(M)[1] <- sprintf("%-17s", paste(s, ":", sep = ""))
          if (is.null(x$efa)) {
            LHS <- paste(x$lhs[row.idx], x$op[row.idx])
          } else {
            LHS <- paste(
              x$lhs[row.idx], x$op[row.idx],
              x$efa[row.idx]
            )
          }
          lhs.idx <- seq(1, nel * 2L, 2L)
          rhs.idx <- seq(1, nel * 2L, 2L) + 1L
          if (s == "Covariances") {
            # make distinction between residual and plain
            y.names <- unique(c(
              lav_object_vnames(x, "eqs.y"),
              lav_object_vnames(x, "ov.ind"),
              lav_object_vnames(x, "lv.ind")
            ))
            PREFIX <- rep("", length(row.idx))
            PREFIX[x$lhs[row.idx] %in% y.names] <- "."
          } else {
            PREFIX <- rep("", length(LHS))
          }
          M[lhs.idx, 1] <- sprintf("%1s%-15s", PREFIX, LHS)
          M[rhs.idx, ] <- m[row.idx, ]
          # avoid duplicated LHS labels
          if (nel > 1L) {
            del.idx <- integer(0)
            old.lhs <- ""
            for (i in 1:nel) {
              if (LHS[i] == old.lhs) {
                del.idx <- c(del.idx, lhs.idx[i])
              }
              old.lhs <- LHS[i]
            }
            if (length(del.idx) > 0L) {
              M <- M[-del.idx, , drop = FALSE]
            }
          }
          cat("\n", s, ":\n", sep = "")
          # cat("\n")
          print(M, quote = FALSE)

          # R-square
        } else if (s == "R-Square") {
          M <- m[row.idx, 1:2, drop = FALSE]
          colnames(M) <- colnames(m)[1:2]
          rownames(M) <- rep("", NROW(M))
          # colnames(M)[1] <- sprintf("%-17s", paste(s, ":", sep = ""))
          cat("\n", s, ":\n", sep = "")
          # cat("\n")
          print(M, quote = FALSE)

          # Regular
        } else {
          # M <- rbind(matrix("", nrow = 1L, ncol = ncol(m)),
          #           m[row.idx,])
          M <- m[row.idx, , drop = FALSE]
          colnames(M) <- colnames(m)
          rownames(M) <- rep("", NROW(M))
          # colnames(M)[1] <- sprintf("%-17s", paste(s, ":", sep = ""))
          cat("\n", s, ":\n", sep = "")
          # cat("\n")
          print(M, quote = FALSE)
        }
      } # GSECTIONS
    } # levels
  } # groups

  # asections
  for (s in ASECTIONS) {
    if (s == "Defined Parameters") {
      row.idx <- which(x$op == ":=")
      m[row.idx, 1] <- lav_print_format_names(x$lhs[row.idx], "")
      M <- m[row.idx, , drop = FALSE]
      colnames(M) <- colnames(m)
    } else if (s == "Constraints") {
      row.idx <- which(x$op %in% c("==", "<", ">"))
      if (length(row.idx) == 0) next
      m[row.idx, 1] <- lav_print_format_constraints(x$lhs[row.idx], x$op[row.idx],
        x$rhs[row.idx],
        nd = nd
      )
      m[row.idx, 2] <- sprintf(num.format, abs(x$est[row.idx]))
      M <- m[row.idx, 1:2, drop = FALSE]
      colnames(M) <- c("", sprintf(char.format, "|Slack|"))
    } else {
      row.idx <- integer(0L)
    }

    if (length(row.idx) == 0L) {
      next
    }

    rownames(M) <- rep("", NROW(M))
    # colnames(M)[1] <- sprintf("%-17s", paste(s, ":", sep = ""))
    # cat("\n")
    cat("\n", s, ":\n", sep = "")
    print(M, quote = FALSE)
  }
  cat("\n")

  invisible(m)
}

lav_print_format_names <- function(NAMES, LABELS, PREFIX = NULL) {
  W <- 14
  if (is.null(PREFIX)) {
    PREFIX <- rep("", length(NAMES))
  }

  multiB <- FALSE
  if (any(nchar(NAMES) != nchar(NAMES, "bytes"))) {
    multiB <- TRUE
  }
  if (any(nchar(LABELS) != nchar(LABELS, "bytes"))) {
    multiB <- TRUE
  }
  # labels?
  l.idx <- which(nchar(LABELS) > 0L)
  if (length(l.idx) > 0L) {
    if (!multiB) {
      LABELS <- abbreviate(LABELS, 4)
      LABELS[l.idx] <- paste(" (", LABELS[l.idx], ")", sep = "")
      MAX.L <- max(nchar(LABELS))
      NAMES <- abbreviate(NAMES,
        minlength = (W - MAX.L),
        strict = TRUE
      )
    } else {
      # do not abbreviate anything (eg in multi-byte locales)
      MAX.L <- 4L
    }
    NAMES <- sprintf(paste("%-", (W - MAX.L), "s%", MAX.L, "s",
      sep = ""
    ), NAMES, LABELS)
  } else {
    if (!multiB) {
      NAMES <- abbreviate(NAMES, minlength = W, strict = TRUE)
    } else {
      NAMES <- sprintf(paste("%-", W, "s", sep = ""), NAMES)
    }
  }

  char.format <- paste("%3s%-", W, "s", sep = "")
  sprintf(char.format, PREFIX, NAMES)
}

lav_print_format_constraints <- function(lhs, op, rhs, nd) {
  nd <- max(nd, 3)
  W <- 41 + (nd - 3) * 3

  nel <- length(lhs)
  if (length(nel) == 0L) {
    return(character(0))
  }
  NAMES <- character(nel)
  for (i in 1:nel) {
    if (rhs[i] == "0" && op[i] == ">") {
      con.string <- paste(lhs[i], " - 0", sep = "")
    } else if (rhs[i] == "0" && op[i] == "<") {
      con.string <- paste(rhs[i], " - (", lhs[i], ")", sep = "")
    } else if (rhs[i] != "0" && op[i] == ">") {
      con.string <- paste(lhs[i], " - (", rhs[i], ")", sep = "")
    } else if (rhs[i] != "0" && op[i] == "<") {
      con.string <- paste(rhs[i], " - (", lhs[i], ")", sep = "")
    } else if (rhs[i] == "0" && op[i] == "==") {
      con.string <- paste(lhs[i], " - 0", sep = "")
    } else if (rhs[i] != "0" && op[i] == "==") {
      con.string <- paste(lhs[i], " - (", rhs[i], ")", sep = "")
    }
    con.string <- abbreviate(con.string, W, strict = TRUE)
    char.format <- paste("   %-", W, "s", sep = "")
    NAMES[i] <- sprintf(char.format, con.string)
  }

  NAMES
}

lav_fsr_summary <- function(object, ...) {
  dotdotdot <- list(...)
  if (!is.null(dotdotdot$nd)) {
    nd <- dotdotdot$nd
  } else {
    nd <- 3L
  }

  lav_fsr_print(x = object, nd = nd, mm = TRUE, struc = TRUE)
}

lav_fsr_print <- function(x, ..., nd = 3L, mm = FALSE, struc = FALSE) {
  y <- unclass(x)

  # print header
  if (!is.null(y$header)) {
    cat(y$header)
    cat("\n")
  }

  if (mm && !is.null(y$MM.FIT)) {
    cat("\n")
    nblocks <- length(y$MM.FIT)
    for (b in seq_len(nblocks)) {
      cat(
        "Measurement block for latent variable(s):",
        paste(lav_object_vnames(y$MM.FIT[[b]], "lv")), "\n"
      )

      # fit measures?
      b.options <- lavInspect(y$MM.FIT[[b]], "options")
      if (!(length(b.options$test) == 1L && b.options$test == "none")) {
        cat("\n")
        print(fitMeasures(y$MM.FIT[[b]], c("chisq", "df", "pvalue", "cfi", "rmsea", "srmr")))
      }

      # parameter estimates
      PE <- lavParameterEstimates(y$MM.FIT[[b]],
        ci = FALSE,
        output = "text", header = TRUE
      )
      lav_parameterestimates_print(PE, ..., nd = nd)
      cat("\n")
    }
  }

  # print PE
  if (struc) {
    cat("Structural Part\n")
    cat("\n")
    print(summary(y$STRUC.FIT,
      fit.measures = FALSE, estimates = FALSE,
      modindices = FALSE
    ))
    FIT <- fitMeasures(y$STRUC.FIT, fit.measures = "default")
    if (FIT["df"] > 0) {
      lav_fitmeasures_print(FIT, add.h0 = FALSE)
    }
  }
  PE <- lavParameterEstimates(y$STRUC.FIT,
    ci = FALSE,
    remove.eq = FALSE, remove.system.eq = TRUE,
    remove.ineq = FALSE, remove.def = FALSE,
    remove.nonfree = FALSE, remove.unused = TRUE,
    output = "text", header = TRUE
  )
  lav_parameterestimates_print(PE, ..., nd = nd)

  invisible(y)
}

# new in 0.6-12
lav_summary_print <- function(x, ..., nd = 3L) {
  y <- unclass(x) # change to ordinary list

  # get nd, if it is stored as an attribute
  ND <- attr(y, "nd")
  if (!is.null(ND) && is.numeric(ND)) {
    nd <- as.integer(ND)
  }

  # header
  if (!is.null(y$header)) {
    lavaan.version <- y$header$lavaan.version
    sam.approach <- y$header$sam.approach
    optim.method <- y$header$optim.method
    optim.iterations <- y$header$optim.iterations
    optim.converged <- y$header$optim.converged

    # sam or sem?
    if (sam.approach) {
      cat("This is ",
        sprintf("lavaan %s", lavaan.version),
        " -- using the SAM approach to SEM\n",
        sep = ""
      )
    } else {
      cat(sprintf("lavaan %s ", lavaan.version))

      # Convergence or not?
      if (optim.method == "none") {
        cat("-- DRY RUN with 0 iterations --\n")
      } else if (optim.iterations > 0) {
        if (optim.converged) {
          if (optim.iterations == 1L) {
            cat("ended normally after 1 iteration\n")
          } else {
            cat(sprintf(
              "ended normally after %i iterations\n",
              optim.iterations
            ))
          }
        } else {
          if (optim.iterations == 1L) {
            cat("did NOT end normally after 1 iteration\n")
          } else {
            cat(sprintf(
              "did NOT end normally after %i iterations\n",
              optim.iterations
            ))
          }
          cat("** WARNING ** Estimates below are most likely unreliable\n")
        }
      } else {
        cat("did not run (perhaps do.fit = FALSE)?\n")
        cat("** WARNING ** Estimates below are simply the starting values\n")
      }
    }
  }

  #TDJ: print header for lavaan.mi object (or nothing when NULL)
  cat(y$top_of_lavaanmi)

  # optim
  if (!is.null(y$optim)) {
    estimator <- y$optim$estimator
    estimator.args <- y$optim$estimator.args
    optim.method <- y$optim$optim.method
    npar <- y$optim$npar
    eq.constraints <- y$optim$eq.constraints
    nrow.ceq.jac <- y$optim$nrow.ceq.jac
    nrow.cin.jac <- y$optim$nrow.cin.jac
    nrow.con.jac <- y$optim$nrow.con.jac
    con.jac.rank <- y$optim$con.jac.rank

    cat("\n")
    # cat("Optimization information:\n\n")

    c1 <- c("Estimator")
    # second column
    tmp.est <- toupper(estimator)
    if (tmp.est == "DLS") {
      dls.first.letter <- substr(
        estimator.args$dls.GammaNT,
        1L, 1L
      )
      tmp.est <- paste("DLS-", toupper(dls.first.letter), sep = "")
    }
    c2 <- tmp.est

    # additional estimator args
    if (!is.null(estimator.args) &&
      length(estimator.args) > 0L) {
      if (estimator == "DLS") {
        c1 <- c(c1, "Estimator DLS value for a")
        c2 <- c(c2, estimator.args$dls.a)
      }
    }

    # optimization method + npar
    c1 <- c(c1, "Optimization method", "Number of model parameters")
    c2 <- c(c2, toupper(optim.method), npar)

    # optional output
    if (eq.constraints) {
      c1 <- c(c1, "Number of equality constraints")
      c2 <- c(c2, nrow.ceq.jac)
    }
    if (nrow.cin.jac > 0L) {
      c1 <- c(c1, "Number of inequality constraints")
      c2 <- c(c2, nrow.cin.jac)
    }
    if (nrow.con.jac > 0L) {
      if (con.jac.rank == (nrow.ceq.jac + nrow.cin.jac)) {
        # nothing to do (don't print, as this is redundant information)
      } else {
        c1 <- c(c1, "Row rank of the constraints matrix")
        c2 <- c(c2, con.jac.rank)
      }
    }

    # format
    c1 <- format(c1, width = 40L)
    c2 <- format(c2,
      width = 11L + max(0, (nd - 3L)) * 4L,
      justify = "right"
    )

    # character matrix
    M <- cbind(c1, c2, deparse.level = 0)
    colnames(M) <- rep("", ncol(M))
    rownames(M) <- rep(" ", nrow(M))

    # print
    write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
  }

  # sam header
  if (!is.null(y$sam.header)) {
    cat("\n")
    sam.method <- y$sam.header$sam.method
    sam.local.options <- y$sam.header$sam.local.options
    sam.mm.list <- y$sam.header$sam.mm.list
    sam.mm.estimator <- y$sam.header$sam.mm.estimator
    sam.struc.estimator <- y$sam.header$sam.struc.estimator

    # sam method
    c1 <- c("SAM method")
    c2 <- toupper(sam.method)

    # options
    if (sam.method == "local") {
      c1 <- c(c1, "Mapping matrix M method")
      c2 <- c(c2, sam.local.options$M.method)
      # TODo: more!
    }

    # number of measurement blocks
    c1 <- c(c1, "Number of measurement blocks")
    c2 <- c(c2, length(sam.mm.list))

    # estimator measurement blocks
    c1 <- c(c1, "Estimator measurement part")
    c2 <- c(c2, sam.mm.estimator)

    # estimator structural part
    c1 <- c(c1, "Estimator  structural part")
    c2 <- c(c2, sam.struc.estimator)

    # format
    c1 <- format(c1, width = 40L)
    c2 <- format(c2,
      width = 11L + max(0, (nd - 3L)) * 4L,
      justify = "right"
    )

    # character matrix
    M <- cbind(c1, c2, deparse.level = 0)
    colnames(M) <- rep("", ncol(M))
    rownames(M) <- rep(" ", nrow(M))

    # print
    write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
  }

  # efa/rotation
  if (!is.null(y$rotation)) {
    cat("\n")
    rotation <- y$rotation
    rotation.args <- y$rotation.args

    # cat("Rotation information:\n\n")
    # container
    c1 <- c2 <- character(0L)

    # rotation method
    c1 <- c(c1, "Rotation method")
    if (rotation$rotation == "none") {
      MM <- toupper(rotation$rotation)
    } else if (rotation$rotation.args$orthogonal) {
      MM <- paste(toupper(rotation$rotation), " ", "ORTHOGONAL",
        sep = ""
      )
    } else {
      MM <- paste(toupper(rotation$rotation), " ", "OBLIQUE",
        sep = ""
      )
    }
    c2 <- c(c2, MM)

    if (rotation$rotation != "none") {
      # method options
      if (rotation$rotation == "geomin") {
        c1 <- c(c1, "Geomin epsilon")
        c2 <- c(c2, rotation$rotation.args$geomin.epsilon)
      } else if (rotation$rotation == "orthomax") {
        c1 <- c(c1, "Orthomax gamma")
        c2 <- c(c2, rotation$rotation.args$orthomax.gamma)
      } else if (rotation$rotation == "cf") {
        c1 <- c(c1, "Crawford-Ferguson gamma")
        c2 <- c(c2, rotation$rotation.args$cf.gamma)
      } else if (rotation$rotation == "oblimin") {
        c1 <- c(c1, "Oblimin gamma")
        c2 <- c(c2, rotation$rotation.args$oblimin.gamma)
      } else if (rotation$rotation == "promax") {
        c1 <- c(c1, "Promax kappa")
        c2 <- c(c2, rotation$rotation.args$promax.kappa)
      }

      # rotation algorithm
      c1 <- c(c1, "Rotation algorithm (rstarts)")
      tmp <- paste(toupper(rotation$rotation.args$algorithm),
        " (", rotation$rotation.args$rstarts, ")",
        sep = ""
      )
      c2 <- c(c2, tmp)

      # Standardized metric (or not)
      c1 <- c(c1, "Standardized metric")
      if (rotation$rotation.args$std.ov) {
        c2 <- c(c2, "TRUE")
      } else {
        c2 <- c(c2, "FALSE")
      }

      # Row weights
      c1 <- c(c1, "Row weights")
      tmp.txt <- rotation$rotation.args$row.weights
      c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
        substring(tmp.txt, 2),
        sep = ""
      ))
    }

    # format c1/c2
    c1 <- format(c1, width = 33L)
    c2 <- format(c2,
      width = 18L + max(0, (nd - 3L)) * 4L,
      justify = "right"
    )

    # create character matrix
    M <- cbind(c1, c2, deparse.level = 0)
    colnames(M) <- rep("", ncol(M))
    rownames(M) <- rep(" ", nrow(M))

    # print
    write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
  }

  # data object
  if (!is.null(y$data)) {
    cat("\n")
    lav_data_print_short(y$data, nd = nd)
  }

  # sam local stats: measurement blocks + structural part
  if (!is.null(y$sam)) {
    cat("\n")
    sam.method <- y$sam$sam.method
    sam.mm.table <- y$sam$sam.mm.table
    sam.mm.rel <- y$sam$sam.mm.rel
    sam.struc.fit <- y$sam$sam.struc.fit
    ngroups <- y$sam$ngroups
    nlevels <- y$sam$nlevels
    group.label <- y$sam$group.label
    level.label <- y$sam$level.label
    block.label <- y$sam$block.label

    # measurement
    tmp <- sam.mm.table
    if (sam.method == "global") {
      cat("Summary Information Measurement Part:\n\n")
    } else {
      cat("Summary Information Measurement + Structural:\n\n")
    }
    print(tmp, row.names = rep(" ", nrow(tmp)), nd = nd)

    if (sam.method == "local") {
      # reliability information
      c1 <- c2 <- character(0L)
      if (ngroups == 1L && nlevels == 1L) {
        cat("\n")
        cat("  Model-based reliability latent variables:\n\n")
        tmp <- data.frame(as.list(sam.mm.rel[[1]]))
        class(tmp) <- c("lavaan.data.frame", "data.frame")
        print(tmp, row.names = rep(" ", nrow(tmp)), nd = nd)
      } else if (ngroups > 1L && nlevels == 1L) {
        cat("\n")
        cat("  Model-based reliability latent variables (per group):\n")
        for (g in 1:ngroups) {
          cat("\n")
          cat("  Group ", g, " [", group.label[g], "]:\n\n",
            sep = ""
          )
          tmp <- data.frame(as.list(sam.mm.rel[[g]]))
          class(tmp) <- c("lavaan.data.frame", "data.frame")
          print(tmp, row.names = rep(" ", nrow(tmp)), nd = nd)
        }
      } else if (ngroups == 1L && nlevels > 1L) {
        cat("\n")
        cat("  Model-based reliability latent variables (per level):\n")
        for (g in 1:nlevels) {
          cat("\n")
          cat("  Level ", g, " [", level.label[g], "]:\n\n",
            sep = ""
          )
          tmp <- data.frame(as.list(sam.mm.rel[[g]]))
          class(tmp) <- c("lavaan.data.frame", "data.frame")
          print(tmp, row.names = rep(" ", nrow(tmp)), nd = nd)
        }
      } else if (ngroups > 1L && nlevels > 1L) {
        cat("\n")
        cat("  Model-based reliability latent variables (per group/level):\n")
        for (g in 1:length(block.label)) {
          cat("\n")
          cat("  Group/Level ", g, " [", block.label[g], "]:\n\n",
            sep = ""
          )
          tmp <- data.frame(as.list(sam.mm.rel[[g]]))
          class(tmp) <- c("lavaan.data.frame", "data.frame")
          print(tmp, row.names = rep(" ", nrow(tmp)), nd = nd)
        }
      }

      cat("\n")
      cat("  Summary Information Structural part:\n\n")
      tmp <- data.frame(as.list(sam.struc.fit))
      class(tmp) <- c("lavaan.data.frame", "data.frame")
      print(tmp, row.names = rep(" ", nrow(tmp)), nd = nd)
    }
  }

  # test statistics
  if (!is.null(y$test)) {
    cat("\n")
    lav_test_print(y$test, nd = nd)
  }

  # extra fit measures (if present)
  if (!is.null(y$fit)) {
    add.h0 <- FALSE
    if (!is.null(attr(y$fit, "add.h0"))) {
      add.h0 <- isTRUE(attr(y$fit, "add.h0"))
    }
    lav_fitmeasures_print(y$fit, nd = nd, add.h0 = add.h0)
  }

  # efa output
  if (!is.null(y$efa)) {
    # get cutoff, if it is stored as an attribute
    CT <- attr(y, "cutoff")
    if (!is.null(CT) && is.numeric(CT)) {
      cutoff <- CT
    } else {
      cutoff <- 0.3
    }
    # get dot.cutoff, if it is stored as an attribute
    DC <- attr(y, "dot.cutoff")
    if (!is.null(DC) && is.numeric(DC)) {
      dot.cutoff <- DC
    } else {
      dot.cutoff <- 0.1
    }
    # get alpha.level, if it is stored as an attribute
    AL <- attr(y, "alpha.level")
    if (!is.null(AL) && is.numeric(AL)) {
      alpha.level <- AL
    } else {
      alpha.level <- 0.01
    }

    for (b in seq_len(y$efa$nblocks)) {
      if (length(y$efa$block.label) > 0L) {
        cat("\n\n")
        cat(y$efa$block.label[[b]], ":\n\n", sep = "")
      }
      if (!is.null(y$efa$lambda[[b]])) {
        cat("\n")
        if (!is.null(y$efa$lambda.se[[b]]) && alpha.level > 0) {
          cat("Standardized loadings: (* = significant at ",
            round(alpha.level * 100),
            "% level)\n\n",
            sep = ""
          )
        } else {
          cat("Standardized loadings:\n\n")
        }
        LAMBDA <- unclass(y$efa$lambda[[b]])
        THETA <- unname(unclass(y$efa$theta[[b]]))
        lav_print_loadings(LAMBDA,
          nd = nd, cutoff = cutoff,
          dot.cutoff = dot.cutoff,
          alpha.level = alpha.level,
          resvar = THETA, # diag elements only
          x.se = y$efa$lambda.se[[b]]
        )
      }

      if (!is.null(y$efa$sumsq.table[[b]])) {
        cat("\n")
        print(y$efa$sumsq.table[[b]], nd = nd)
      }

      # factor correlations:
      if (!y$efa$orthogonal && !is.null(y$efa$psi[[b]]) &&
        ncol(y$efa$psi[[b]]) > 1L) {
        cat("\n")
        if (!is.null(y$efa$psi.se[[b]]) && alpha.level > 0) {
          cat("Factor correlations: (* = significant at ",
            round(alpha.level * 100),
            "% level)\n\n",
            sep = ""
          )
        } else {
          cat("Factor correlations:\n\n")
        }
        lav_print_psi(y$efa$psi[[b]],
          nd = nd,
          alpha.level = alpha.level,
          x.se = y$efa$psi.se[[b]]
        )
      }

      # factor score determinacy (for regression scores only!)
      if (!is.null(y$efa$fs.determinacy[[b]])) {
        cat("\n")
        cat("Correlation regression factor scores and factors (determinacy):\n\n")
        print(y$efa$fs.determinacy[[b]], nd = nd)
        cat("\n")
        cat("R2 regression factor scores (= squared correlations):\n\n")
        tmp <- y$efa$fs.determinacy[[b]]
        tmp2 <- tmp * tmp
        class(tmp2) <- c("lavaan.vector", "numeric")
        print(tmp2, nd = nd)
      }

      # lambda.structure
      if (!is.null(y$efa$lambda.structure[[b]])) {
        cat("\n")
        cat("Standardized structure (= LAMBDA %*% PSI):\n\n")
        print(y$efa$lambda.structure[[b]], nd = nd)
      }

      # standard errors lambda
      if (!is.null(y$efa$theta.se[[b]])) { # we check for theta.se
        # as lambda.se is needed for '*'
        cat("\n")
        cat("Standard errors standardized loadings:\n\n")
        print(y$efa$lambda.se[[b]], nd = nd)
      }

      # z-statistics lambda
      if (!is.null(y$efa$lambda.zstat[[b]])) {
        cat("\n")
        cat("Z-statistics standardized loadings:\n\n")
        print(y$efa$lambda.zstat[[b]], nd = nd)
      }

      # pvalues lambda
      if (!is.null(y$efa$lambda.pvalue[[b]])) {
        cat("\n")
        cat("P-values standardized loadings:\n\n")
        print(y$efa$lambda.pvalue[[b]], nd = nd)
      }

      # standard errors theta
      if (!is.null(y$efa$theta.se[[b]])) {
        cat("\n")
        cat("Standard errors unique variances:\n\n")
        print(y$efa$theta.se[[b]], nd = nd)
      }

      # z-statistics theta
      if (!is.null(y$efa$theta.zstat[[b]])) {
        cat("\n")
        cat("Z-statistics unique variances:\n\n")
        print(y$efa$theta.zstat[[b]], nd = nd)
      }

      # pvalues theta
      if (!is.null(y$efa$theta.pvalue[[b]])) {
        cat("\n")
        cat("P-values unique variances:\n\n")
        print(y$efa$theta.pvalue[[b]], nd = nd)
      }

      # standard errors psi
      if (!is.null(y$efa$theta.se[[b]])) { # we check for theta.se
        # as psi.se is needed for '*'
        cat("\n")
        cat("Standard errors factor correlations:\n\n")
        print(y$efa$psi.se[[b]], nd = nd)
      }

      # z-statistics psi
      if (!is.null(y$efa$psi.zstat[[b]])) {
        cat("\n")
        cat("Z-statistics factor correlations:\n\n")
        print(y$efa$psi.zstat[[b]], nd = nd)
      }

      # pvalues psi
      if (!is.null(y$efa$psi.pvalue[[b]])) {
        cat("\n")
        cat("P-values factor correlations:\n\n")
        print(y$efa$psi.pvalue[[b]], nd = nd)
      }
    } # blocks
    cat("\n")
  } # efa

  # parameter table
  if (!is.null(y$pe) && is.null(y$efa)) {
    PE <- y$pe
    class(PE) <- c(
      "lavaan.parameterEstimates", "lavaan.data.frame",
      "data.frame"
    )
    print(PE, nd = nd)
  }

  # modification indices
  if (!is.null(y$mi)) {
    cat("Modification Indices:\n\n")
    MI <- y$mi
    rownames(MI) <- NULL
    print(MI, nd = nd)
  }

  invisible(y)
}

# helper function to print the loading matrix, masking small loadings
lav_print_loadings <- function(x, nd = 3L, cutoff = 0.3, dot.cutoff = 0.1,
                               alpha.level = 0.01, resvar = NULL, x.se = NULL) {
  # unclass
  y <- unclass(x)

  # round, and create a character matriy
  y <- format(round(y, nd), width = 3L + nd, justify = "right")

  # right-align column names
  colnames(y) <- format(colnames(y), width = 3L + nd, justify = "right")

  # create dot/empty string
  dot.string <- format(".", width = 3L + nd, justify = "right")
  empty.string <- format(" ", width = 3L + nd)

  # print a 'dot' if dot.cutoff < |loading| < cutoff
  if (dot.cutoff < cutoff) {
    y[abs(x) < cutoff & abs(x) > dot.cutoff] <- dot.string
  }

  # print nothing if |loading| < dot.cutoff
  y[abs(x) < min(dot.cutoff, cutoff)] <- empty.string

  # add 'star' for significant loadings (if provided) using alpha = 0.01
  if (!is.null(x.se) && !any(is.na(x.se))) {
    colNAMES <- colnames(y)
    rowNAMES <- rownames(y)
    x.se[x.se < sqrt(.Machine$double.eps)] <- 1 # to avoid NA
    zstat <- x / x.se
    z.cutoff <- qnorm(1 - (alpha.level / 2))
    zstat.string <- ifelse(abs(zstat) > z.cutoff, "*", " ")
    y <- matrix(paste(y, zstat.string, sep = ""), nrow(y), ncol(y))
    colnames(y) <- colNAMES
    rownames(y) <- rowNAMES
  }

  # add resvar
  if (!is.null(resvar)) {
    NAMES <- colnames(y)
    y <- cbind(y, format(round(cbind(resvar, 1 - resvar), nd),
      width = 12L + nd, justify = "right"
    ))
    resvar.names <- format(c("unique.var", "communalities"),
      width = 12L + nd, justify = "right"
    )
    colnames(y) <- c(NAMES, resvar.names)
  }

  # print
  print(y, quote = FALSE)
}

# helper function to print the psi matrix, showing signif stars
lav_print_psi <- function(x, nd = 3L, alpha.level = 0.01, x.se = NULL) {
  # unclass
  y <- unclass(x)

  # round, and create a character matriy
  y <- format(round(y, nd), width = 3L + nd, justify = "right")

  # right-align column names
  colnames(y) <- format(colnames(y), width = 3L + nd, justify = "right")

  # add 'star' for significant loadings (if provided) using alpha = 0.01
  if (!is.null(x.se) && !any(is.na(x.se))) {
    colNAMES <- colnames(y)
    rowNAMES <- rownames(y)
    x.se[x.se < sqrt(.Machine$double.eps)] <- 1 # to avoid NA
    zstat <- x / x.se
    z.cutoff <- qnorm(1 - (alpha.level / 2))
    zstat.string <- ifelse(abs(zstat) > z.cutoff, "*", " ")
    y <- matrix(paste(y, zstat.string, sep = ""), nrow(y), ncol(y))
    colnames(y) <- colNAMES
    rownames(y) <- rowNAMES
  }

  # remove upper part
  ll <- upper.tri(x, diag = FALSE)
  y[ll] <- ""

  # print
  print(y, quote = FALSE)
}

# miscellaneous functions related to graphs
# often using an adjancency matrix as input
#
# collecting functions that were in lav_utils.R
# YR 15 Oct 2025

# find index of 'ancestors' (predictors) for all nodes in a DAG
# given an adjacency matrix B (rows are y's, columns are x's)
#
# this (speedy!) version is written by Luc De Wilde
lav_graph_get_ancestors <- function(B = NULL) {
  B <- abs(B)
  nr <- nrow(B)
  out_env <- new.env(parent = emptyenv())

  # container to hold ancestor indices per node
  out.idx <- vector("list", length = nr)

  get_ancestors <- function(nr, callers) {
    if (any(callers == nr)) {
      lav_msg_warn(gettextf("Cycle detected for element nr %d !", nr))
      return(integer(0))
    }
    x <- get0(as.character(nr), envir = out_env, ifnotfound = NULL)
    if (!is.null(x)) return(x)
    retval <- integer(0L)
    x.direct.idx <- which(B[nr, ] != 0)
    for (j in seq_along(x.direct.idx)) {
      thisone <- x.direct.idx[j]
      retval <- c(retval, thisone)
      sub <- get_ancestors(thisone, c(callers, nr))
      if (all(sub != nr)) retval <- c(retval, sub)
    }
    retval <- sort.int(unique(retval))
    assign(as.character(nr), retval, envir = out_env)
    retval
  }

  # run over each node
  for (i in seq_len(nr)) {
    out.idx[[i]] <- get_ancestors(i, integer(0))
  } # all nodes
  out.idx
}


# cluster rows/cols that are linked/connected
# return list of connected nodes
# we assume A is the square/symmetric (binary) adjacency matrix of an
# undirected graph
#
# this version written by Luc De Wilde
lav_graph_get_connected_nodes <- function(A) {

  # make sure we have square symmetric matrix
  A <- as.matrix(A)

  # A must be square
  stopifnot(nrow(A) == ncol(A))

  # A must be symmetric
  stopifnot(isSymmetric(A))

  # set diagonal to zero (just in case)
  diag(A) <- 0L

  # make it logical
  A <- (A != 0)

  # number of cols/rows
  M <- ncol(A)

  # catch diagonal A
  if (all(lavaan::lav_matrix_vech(A, diagonal = FALSE) == 0L)) {
    return(seq_len(M))
  }

  visited <- rep(FALSE, M)         # track visited nodes
  membership <- integer(M)         # component id for each node
  component.id <- 0L               # current component id

  put_node_in_component <- function(node, componentid) {
    visited[node] <<- TRUE
    membership[node] <<- componentid
    toadd <- which(A[, node])
    for (n in toadd) {
      if (!visited[n]) put_node_in_component(n, componentid)
    }
  }

  for (node in seq_len(M)) {
    if (!visited[node]) {
      component.id <- component.id + 1L
      put_node_in_component(node, component.id)
    }
  }

  membership
}

# This routine tries to order the expressions such that all expressions that
# use a certain variable come after the expression that defines this variable.
# input adj.mat is an adjacency matrix
# when there is a 1 in element (r, c) this means that the variable
# defined in expression r is used in expression c.

# contributed by ldw (adapted from function defined by Kss2k, github issue #445)
lav_graph_order_adj_mat <- function(adj.mat, warn = TRUE) {
  adjmat <- adj.mat
  n <- nrow(adjmat)
  k <- 0
  testen <- 1:n
  while (TRUE) {
    found <- FALSE
    tests <- testen # which expressions are tested in the next loop
    for (i in tests) {
      if (all(adjmat[1:n, i] == 0)) { # var defined in expression i doesn't use
        # vars not already defined, select as next
        k <- k + 1            # increment order counter
        adjmat[i, ] <- 0      # remove usage indicator of defined variable
        adjmat[i, i] <- k     # keep order of expressions in diagonal element
        found <- TRUE
        testen <- testen[testen != i] # don't test this i in next loop
      }
    }
    if (k == n) return(order(diag(adjmat)))  # all done
    if (!found) {  # no definable var found
        if (warn) {
          lav_msg_warn(gettext("unable to sort `:=` parameters;",
                               "system of defined parameters contains a cycle"))
        }
        return(seq_len(n))    # cycle detected; return original order
    }
  }
}

  # This function performs the same task as lav_graph_order_adj_mat but
  # takes as input two vectors (character or integer) of the same length
  # defining the dependencies:
  # inputs are vectors defined and definedby of the same length, where
  # for each index j for these vectors
  # node definedby[j] is used in the definition of node defined[j].
  # This routine tries to order all nodes such that all node definitions that
  # use a certain node come after the definition of that node.

  # contributed by ldw as alternative for lav_graph_order_adj_mat
  # this function is faster, requires less memory and handles also
  # character vectors
lav_graph_topological_sort <- function(defined, definedby, warn = TRUE) {
  nodes <- unique(c(definedby, defined))
  n <- length(nodes)
  rv <- vector(mode(definedby), n)
  k <- 0L
  testnodes <- rep(TRUE, n)
  testedges <- rep(TRUE, length(defined))
  while (TRUE) {
    found <- FALSE
    tests <- which(testnodes)
    for (i in tests) {
      tocheck <- nodes[i]
      if (all(tocheck != defined[testedges])) {
        k <- k + 1L
        testnodes[i] <- FALSE
        rv[k] <- tocheck
        found <- TRUE
        testedges[definedby == tocheck] <- FALSE
      }
    }
    if (k == n) return(rv)  # all done
    if (!found) {  # no definable node found
      if (warn) {
        lav_msg_warn(gettext("unable to sort;",
                             "dependencies contain a cycle"))
      }
      return(nodes)    # cycle detected; return original order
    }
  }
}

# Topological grouping and placing of nodes in a matrix.
# Nodes which need to be placed at a border are given in argument bordernodes.
# This routine does a topological sort and returns a data.frame with the nodes,
# their position in a  matrix (rows, cols) and an indication of root
# (no dependencies, indic == "r") or
# leave (no other nodes depend on this one, indic == "l"), as follows :
# the first column contains all nodes without dependencies (*1) (*2)
# the second column contains nodes with only dependency
#                                       in the first column (*1)(*3)
# the third column contains nodes with only dependencies in the first and
#     second, with at least one in the second column and so on (*3)
# (*1) nodes with successors but no successors in the next column are promoted
#     to the column just before the least column of the successors, except
#     the nodes mentioned in bordernodes and in the first column.
# (*2) the rows in the first column are chosen so that they are in the
#     neighborhood of the mean of the rows from the nodes depending on them.(*4)
# (*3) the rows in the second to last column are chosen so that the sum of the
#     row-distances to connected nodes is minimized
# (*4) if there are nodes forced to the top border in columns 2 through
#     maxcol-1, the items in column1s 1 and maxcol cannot occupy the first row;
#     analogue for the bottom
lav_graph_topological_matrix <- function(
  defined,
  definedby,
  bordernodes = character(0),
  warn = TRUE) {
  rv <- lav_graph_topological_sort(defined, definedby, warn)
  n <- length(rv)
  rvrow <- integer(n)
  rvcol <- integer(n)
  rvindic <- character(n)
  # position nodes in matrix, column by column, and mark root and leave nodes
  # rows are assigned but not yet adapted
  colmax <- 0L
  bordersincol <- 0L
  topborderfixed <- FALSE
  bottomborderfixed <- FALSE
  for (i in seq.int(n)) {
    predecessors <- definedby[rv[i] == defined]
    followers <- defined[rv[i] == definedby]
    if (length(predecessors) == 0L) {
      rvcol[i] <- 1L
      colmax[1L] <- colmax[1L] + 1L
      rvrow[i] <- colmax[1L]
      rvindic[i] <- "r" # root
    } else {
      if (length(followers) == 0L) {
        rvindic[i] <- "l"
      }
      predecessor.ind <- match(predecessors, rv)
      rvcol[i] <- max(rvcol[predecessor.ind]) + 1L
      if (length(colmax) < rvcol[i]) {
        colmax[rvcol[i]] <- 1L
        bordersincol <- 0L
      } else {
        colmax[rvcol[i]] <- colmax[rvcol[i]] + 1L
      }
      rvrow[i] <- colmax[rvcol[i]]
      if (rv[i] %in% bordernodes && rvindic[i] != "l") {
        bordersincol <- bordersincol + 1L
        topborderfixed <- TRUE
        if (bordersincol == 2L) bottomborderfixed <- TRUE
        if (bordersincol > 2L) {
          rvcol[i]  <- rvcol[i] + 1L
          colmax[rvcol[i]] <- 1L
          rvrow[i] <- colmax[rvcol[i]]
        }
      }
    }
  }
  # increment columns ? (*)
  incremented <- TRUE
  while (incremented) {
    incremented <- FALSE
    for (i in seq_along(rv)) {
      if (rvindic[i] != "l" && !(rv[i] %in% bordernodes && rvindic[i] == "r")) {
        followers <- defined[rv[i] == definedby]
        followers.ind <- match(followers, rv)
        mincol <- min(rvcol[followers.ind])
        if (rvcol[i] < mincol - 1L) {
          incremented <- TRUE
          curcol <- rvcol[i]
          rvcol[i] <- mincol - 1L
          # adapt rows in curcol
          rvrow[rvcol == curcol & rvrow > rvrow[i]] <-
            rvrow[rvcol == curcol & rvrow > rvrow[i]] - 1L
          colmax[curcol] <- colmax[curcol] - 1L
          # adapt rows in newcol
          colmax[mincol - 1L] <- colmax[mincol - 1L] + 1L
          rvrow[i] <- colmax[mincol - 1L]
        }
      }
    }
  }
  # place bordernodes in columns 2 through maxcol-1 in the first or last row
  for (col in seq.int(2L, length(colmax) - 1L)) {
    bordernodes.incol <- which(rvcol == col & rv %in% bordernodes)
    if (length(bordernodes.incol) > 0L) {
      totop <- bordernodes.incol[1L]
      if (rvrow[totop] != 1L) {
        swappie <- which(rvcol == col & rvrow == 1L)
        rvrow[swappie] <- rvrow[totop]
        rvrow[totop] <- 1L
      }
    }
    if (length(bordernodes.incol) > 1L) {
      tobottom <- bordernodes.incol[2L]
      if (rvrow[tobottom] != colmax[col]) {
        swappie <- which(rvcol == col & rvrow == colmax[col])
        rvrow[swappie] <- rvrow[tobottom]
        rvrow[tobottom] <- max(colmax)
      }
    }
  }
  # help function to order doubles as integers in a specified range
  order_doubles_interval <- function(inorder, outrange) {
    stopifnot(length(inorder) < outrange[2] - outrange[1] + 2)
    if (length(inorder) == 1) {
      if (inorder >= outrange[1L] && inorder <= outrange[2L]) {
        return(as.integer(inorder))
      }
      return(as.integer(sum(outrange) / 2))
    }
    in.order <- order(inorder)
    in.order[in.order] <- seq_along(inorder)
    if (length(inorder) == outrange[2] - outrange[1] + 1) {
      return(as.integer(outrange[1]) + in.order - 1L)
    }
    as.integer(outrange[1] + (in.order - 1L) *
      (outrange[2] - outrange[1] + 0.99) / (length(in.order) - 1L))
  }
  # arrange nodes in first column (***)
  rowmax <- max(colmax)
  addrows <- 0L
  if (topborderfixed) addrows <- 1L
  if (bottomborderfixed) addrows <- 2L
  rowmax <- max(colmax, colmax[1L] + addrows, colmax[length(colmax)] + addrows)
  nodescol1 <- which(rvcol == 1L)
  optimalrows <- sapply(nodescol1, function(ci) {
    nextnodes.ind <- which(rv[ci] == definedby)
    if (length(nextnodes.ind) == 0L) {
      colmax[1L] / 2
    } else {
      nextnodes <- defined[nextnodes.ind]
      mean(rvrow[match(nextnodes, rv)])
    }
  })
  interval1l <- c(
    if (topborderfixed) 2L else 1L,
    if (bottomborderfixed) rowmax - 1L else rowmax
  )
  rvrow[nodescol1] <- order_doubles_interval(optimalrows, interval1l)

  # adapt rows in columns to match as close as possible the rows of the
  # connected nodes in prior column(s), except for
  # borders for all but the last column: (**)
  if (length(colmax) > 1L) {
    for (c in seq.int(2L, length(colmax))) {
      if (c == length(colmax)) {
        cnodes.ind <- which(rvcol == c)
        interval <- interval1l
      } else {
        cnodes.ind <- which(rvcol == c & !(rv %in% bordernodes))
        if (length(cnodes.ind) == 0L) next
        interval <- range(rvrow[cnodes.ind])
        interval[2L] <- max(interval[2L], colmax - 1L)
      }
      optimalrows <- sapply(cnodes.ind, function(ci) {
        prevnodes.ind <- which(rv[ci] == defined)
        if (length(prevnodes.ind) == 0L) {
          rvrow[ci]
        } else {
          prevnodes <- definedby[prevnodes.ind]
          mean(rvrow[match(prevnodes, rv)])
        }
      })
      rvrow[cnodes.ind] <- order_doubles_interval(optimalrows, interval)
    }
  }
  # order on column, then row, and return
  neworder <- order(rvcol * 1000L + rvrow)
  stopifnot(length(neworder) == length(unique(neworder)))
  data.frame(
    nodes = rv[neworder],
    rows = rvrow[neworder],
    cols = rvcol[neworder],
    indic = rvindic[neworder]
  )
}

# rotation algorithms
#
# YR  3 April 2019 -- gradient projection algorithm
# YR 21 April 2019 -- pairwise rotation algorithm
# YR 11 May   2020 -- order.idx is done in rotation matrix
#                     (suggested by Florian Scharf)
# YR 02 June  2024 -- add group argument, so target and target.mask can
#                     be a list

# main function to rotate a single matrix 'A'
lav_matrix_rotate <- function(A = NULL, # original matrix
                              orthogonal = FALSE, # default is oblique
                              method = "geomin", # default rot method
                              method.args = list(
                                geomin.epsilon = 0.01,
                                orthomax.gamma = 1,
                                cf.gamma = 0,
                                oblimin.gamma = 0,
                                promax.kappa = 4,
                                target = matrix(0, 0, 0),
                                target.mask = matrix(0, 0, 0)
                              ),
                              init.ROT = NULL, # initial rotation matrix
                              init.ROT.check = TRUE, # check if init ROT is ok
                              rstarts = 100L, # number of random starts
                              row.weights = "default", # row weighting
                              std.ov = FALSE, # rescale ov
                              ov.var = NULL, # ov variances
                              algorithm = "gpa", # rotation algorithm
                              reflect = TRUE, # refect sign
                              order.lv.by = "index", # how to order the lv's
                              gpa.tol = 0.00001, # stopping tol gpa
                              tol = 1e-07, # stopping tol others
                              keep.rep = FALSE, # store replications
                              max.iter = 10000L, # max gpa iterations
							  group = 1L) { # group number

  # check A
  if (!inherits(A, "matrix")) {
    lav_msg_stop(gettext("A does not seem to be a matrix"))
  }

  P <- nrow(A)
  M <- ncol(A)
  if (M < 2L) { # single dimension
    res <- list(
      LAMBDA = A, PHI = matrix(1, 1, 1), ROT = matrix(1, 1, 1),
      orthogonal = orthogonal, method = "none",
      method.args = list(), row.weights = "none",
      algorithm = "none", iter = 0L, converged = TRUE,
      method.value = 0
    )
    return(res)
  }

  # method
  method <- tolower(method)

  # if promax, skip everything, then call promax() later
  if (method == "promax") {
    # orig.algorithm <- algorithm
    # orig.rstarts <- rstarts

    algorithm <- "none"
    rstarts <- 0L
    init.ROT <- NULL
    ROT <- diag(M)
  }

  # check init.ROT
  if (!is.null(init.ROT) && init.ROT.check) {
    if (!inherits(init.ROT, "matrix")) {
      lav_msg_stop(gettext("init.ROT does not seem to a matrix"))
    }
    if (nrow(init.ROT) != M) {
      lav_msg_stop(gettextf(
        "nrow(init.ROT) = %1$s does not equal ncol(A) = %2$s",
        nrow(init.ROT), M))
    }
    if (nrow(init.ROT) != ncol(init.ROT)) {
      lav_msg_stop(gettextf(
        "nrow(init.ROT) = %1$s does not equal ncol(init.ROT) = %2$s",
        nrow(init.ROT), ncol(init.ROT)))
    }
    # rotation matrix?
    if (!lav_matrix_rotate_check(init.ROT, orthogonal = orthogonal)) {
      lav_msg_stop(gettext("init.ROT does not look like a rotation matrix"))
    }
  }

  # determine method function name
  if (method %in% c(
    "cf-quartimax", "cf-varimax", "cf-equamax",
    "cf-parsimax", "cf-facparsim"
  )) {
    method.fname <- "lav_matrix_rotate_cf"
    method.args$cf.gamma <- switch(method,
      "cf-quartimax" = 0,
      "cf-varimax"   = 1 / P,
      "cf-equamax"   = M / (2 * P),
      "cf-parsimax"  = (M - 1) / (P + M - 2),
      "cf-facparsim" = 1
    )
  } else if (method %in% c("bi-quartimin", "biquartimin")) {
    method.fname <- "lav_matrix_rotate_biquartimin"
  } else if (method %in% c("bi-geomin", "bigeomin")) {
    method.fname <- "lav_matrix_rotate_bigeomin"
  } else if (method == "target.strict") {
    method.fname <- "lav_matrix_rotate_target"
  } else {
    method.fname <- paste("lav_matrix_rotate_", method, sep = "")
  }

  # check if rotation method exists
  check <- try(get(method.fname), silent = TRUE)
  if (inherits(check, "try-error")) {
    lav_msg_stop(gettext("unknown rotation method:"), method.fname)
  }

  # if target, check target matrix
  if (method == "target.strict" || method == "pst") {
    target <- method.args$target
	if (is.list(target)) {
	  method.args$target <- target <- target[[group]]
	}
    # check dimension of target/A
    if (nrow(target) != nrow(A)) {
      lav_msg_stop(gettext("nrow(target) != nrow(A)"))
    }
    if (ncol(target) != ncol(A)) {
      lav_msg_stop(gettext("ncol(target) != ncol(A)"))
    }
  }
  if (method == "pst") {
    target.mask <- method.args$target.mask
	if (is.list(target.mask)) {
	  method.args$target.mask <- target.mask <- target.mask[[group]]
	}
    # check dimension of target.mask/A
    if (nrow(target.mask) != nrow(A)) {
      lav_msg_stop(gettext("nrow(target.mask) != nrow(A)"))
    }
    if (ncol(target.mask) != ncol(A)) {
      lav_msg_stop(gettext("col(target.mask) != ncol(A)"))
    }
  }
  # we keep this here, so lav_matrix_rotate() can be used independently
  if (method == "target.strict" && anyNA(target)) {
    method <- "pst"
    method.fname <- "lav_matrix_rotate_pst"
    target.mask <- matrix(1, nrow = nrow(target), ncol = ncol(target))
    target.mask[is.na(target)] <- 0
    method.args$target.mask <- target.mask
  }

  # set orthogonal option
  if (missing(orthogonal)) {
    # the default is oblique, except for varimax, entropy and a few others
    if (method %in% c(
      "varimax", "entropy", "mccammon",
      "tandem1", "tandem2"
    )) {
      orthogonal <- TRUE
    } else {
      orthogonal <- FALSE
    }
  } else {
    if (!orthogonal && method %in% c(
      "varimax", "entropy", "mccammon",
      "tandem1", "tandem2"
    )) {
      lav_msg_warn(gettextf(
        "rotation method %s may not work with oblique rotation.",
        dQuote(method)
      ))
    }
  }

  # set row.weights
  row.weights <- tolower(row.weights)
  if (row.weights == "default") {
    # the default is "none", except for varimax
    if (method %in% c("varimax", "promax")) {
      row.weights <- "kaiser"
    } else {
      row.weights <- "none"
    }
  }

  # check algorithm
  algorithm <- tolower(algorithm)
  if (algorithm %in% c("gpa", "pairwise", "none")) {
    # nothing to do
  } else {
    lav_msg_stop(gettext("algorithm must be gpa or pairwise"))
  }



  # 1. compute row weigths

  # 1.a cov -> cor?
  if (std.ov) {
    A <- A * 1 / sqrt(ov.var)
  }

  if (row.weights == "none") {
    weights <- rep(1.0, P)
  } else if (row.weights == "kaiser") {
    weights <- lav_matrix_rotate_kaiser_weights(A)
  } else if (row.weights == "cureton-mulaik") {
    weights <- lav_matrix_rotate_cm_weights(A)
  } else {
    lav_msg_stop(gettext("row.weights can be none, kaiser or cureton-mulaik"))
  }
  A <- A * weights


  # 2. rotate

  # multiple random starts?
  if (rstarts > 0L) {
    REP <- sapply(seq_len(rstarts), function(rep) {
      # random start (always orthogonal)
      init.ROT <- lav_matrix_rotate_gen(M = M, orthogonal = TRUE)
      # init.ROT <- lav_matrix_rotate_gen(M = M, orthogonal = orthogonal)

      if (lav_verbose()) {
        cat("\n")
        cat("rstart = ", sprintf("%4d", rep), " start:\n")
      }


      # choose rotation algorithm
      if (algorithm == "gpa") {
        ROT <- lav_matrix_rotate_gpa(
          A = A, orthogonal = orthogonal,
          init.ROT = init.ROT,
          method.fname = method.fname,
          method.args = method.args,
          gpa.tol = gpa.tol,
          max.iter = max.iter
        )
        info <- attr(ROT, "info")
        attr(ROT, "info") <- NULL
        res <- c(info$method.value, lav_matrix_vec(ROT))
      } else if (algorithm == "pairwise") {
        ROT <- lav_matrix_rotate_pairwise(
          A = A,
          orthogonal = orthogonal,
          init.ROT = init.ROT,
          method.fname = method.fname,
          method.args = method.args,
          tol = tol,
          max.iter = max.iter
        )
        info <- attr(ROT, "info")
        attr(ROT, "info") <- NULL
        res <- c(info$method.value, lav_matrix_vec(ROT))
      }

      if (lav_verbose()) {
        cat(
          "rstart = ", sprintf("%4d", rep),
          " end; current crit = ", sprintf("%17.15f", res[1]), "\n"
        )
      }
      res
    })
    best.idx <- which.min(REP[1, ])
    ROT <- matrix(REP[-1, best.idx], nrow = M, ncol = M)
    if (keep.rep) {
      info <- list(method.value = REP[1, best.idx], REP = REP)
    } else {
      info <- list(method.value = REP[1, best.idx])
    }
  } else if (algorithm != "none") {
    # initial rotation matrix
    if (is.null(init.ROT)) {
      init.ROT <- diag(M)
    }

    # Gradient Projection Algorithm
    if (algorithm == "gpa") {
      ROT <- lav_matrix_rotate_gpa(
        A = A, orthogonal = orthogonal,
        init.ROT = init.ROT,
        method.fname = method.fname,
        method.args = method.args,
        gpa.tol = gpa.tol,
        max.iter = max.iter
      )
    } else if (algorithm == "pairwise") {
      ROT <- lav_matrix_rotate_pairwise(
        A = A,
        orthogonal = orthogonal,
        init.ROT = init.ROT,
        method.fname = method.fname,
        method.args = method.args,
        tol = tol,
        max.iter = max.iter
      )
    }
    info <- attr(ROT, "info")
    attr(ROT, "info") <- NULL
  }

  # final rotation
  if (orthogonal) {
    # LAMBDA <- A %*% solve(t(ROT))
    # note: when ROT is orthogonal, solve(t(ROT)) == ROT
    LAMBDA <- A %*% ROT
    PHI <- diag(ncol(LAMBDA)) # correlation matrix == I
  } else {
    # LAMBDA <- A %*% solve(t(ROT))
    LAMBDA <- t(solve(ROT, t(A)))
    PHI <- crossprod(ROT) # correlation matrix
  }

  # 3. undo row weighting
  LAMBDA <- LAMBDA / weights

  # here, after re-weighted, we run promax if needed
  if (method == "promax") {
    LAMBDA.orig <- LAMBDA

    # first, run 'classic' varimax using varimax() from the stats package
    # we split varimax from promax, so we can control the normalize flag
    normalize.flag <- row.weights == "kaiser"
    xx <- stats::varimax(x = LAMBDA, normalize = normalize.flag)

    # promax
    kappa <- method.args$promax.kappa
    out <- lav_matrix_rotate_promax(
      x = xx$loadings, m = kappa,
      varimax.ROT = xx$rotmat
    )
    LAMBDA <- out$loadings
    PHI <- solve(crossprod(out$rotmat))

    # compute 'ROT' to be compatible with GPa
    ROTt.inv <- solve(
      crossprod(LAMBDA.orig),
      crossprod(LAMBDA.orig, LAMBDA)
    )
    ROT <- solve(t(ROTt.inv))

    info <- list(
      algorithm = "promax", iter = 0L, converged = TRUE,
      method.value = as.numeric(NA)
    )
  }

  # 3.b undo cov -> cor
  if (std.ov) {
    LAMBDA <- LAMBDA * sqrt(ov.var)
  }

  # 4.a reflect so that column sum is always positive
  if (reflect) {
    SUM <- colSums(LAMBDA)
    neg.idx <- which(SUM < 0)
    if (length(neg.idx) > 0L) {
      LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE]
      ROT[, neg.idx] <- -1 * ROT[, neg.idx, drop = FALSE]
      if (!orthogonal) {
        # recompute PHI
        PHI <- crossprod(ROT)
      }
    }
  }

  # 4.b reorder the columns
  if (order.lv.by == "sumofsquares") {
    L2 <- LAMBDA * LAMBDA
    order.idx <- base::order(colSums(L2), decreasing = TRUE)
  } else if (order.lv.by == "index") {
    # reorder using Asparouhov & Muthen 2009 criterion (see Appendix D)
    max.loading <- apply(abs(LAMBDA), 2, max)
    # 1: per factor, number of the loadings that are at least 0.8 of the
    #    highest loading of the factor
    # 2: mean of the index numbers
    average.index <- sapply(seq_len(ncol(LAMBDA)), function(i) {
      mean(which(abs(LAMBDA[, i]) >= 0.8 * max.loading[i]))
    })
    # order of the factors
    order.idx <- base::order(average.index)
  } else if (order.lv.by == "none") {
    order.idx <- seq_len(ncol(LAMBDA))
  } else {
    lav_msg_stop(gettext("order must be index, sumofsquares or none"))
  }

  # do the same in PHI
  LAMBDA <- LAMBDA[, order.idx, drop = FALSE]
  PHI <- PHI[order.idx, order.idx, drop = FALSE]

  # new in 0.6-6, also do this in ROT, so we won't have to do this
  # again upstream
  ROT <- ROT[, order.idx, drop = FALSE]

  # 6. return results as a list
  res <- list(
    LAMBDA = LAMBDA, PHI = PHI, ROT = ROT, order.idx = order.idx,
    orthogonal = orthogonal, method = method,
    method.args = method.args, row.weights = row.weights
  )

  # add method info
  res <- c(res, info)

  res
}


# Gradient Projection Algorithm (Jennrich 2001, 2002)
#
# - this is a translation of the SAS PROC IML code presented in the Appendix
#   of Bernaards & Jennrich (2005)
# - as the orthogonal and oblique algorithm are so similar, they are
#   combined in a single function
# - the default is oblique rotation
#
lav_matrix_rotate_gpa <- function(A = NULL, # original matrix
                                  orthogonal = FALSE, # default is oblique
                                  init.ROT = NULL, # initial rotation
                                  method.fname = NULL, # criterion function
                                  method.args = list(), # optional method args
                                  gpa.tol = 0.00001,
                                  max.iter = 10000L) {
  # number of columns
  M <- ncol(A)

  # transpose of A (not needed for orthogonal)
  At <- t(A)

  # check init.ROT
  if (is.null(init.ROT)) {
    ROT <- diag(M)
  } else {
    ROT <- init.ROT
  }

  # set initial value of alpha to 1
  alpha <- 1

  # initial rotation
  if (orthogonal) {
    LAMBDA <- A %*% ROT
  } else {
    LAMBDA <- t(solve(ROT, At))
  }

  # using the current LAMBDA, evaluate the user-specified
  # rotation criteron; return Q (the criterion) and its gradient Gq
  Q <- do.call(
    method.fname,
    c(list(LAMBDA = LAMBDA), method.args, list(grad = TRUE))
  )
  Gq <- attr(Q, "grad")
  attr(Q, "grad") <- NULL
  Q.current <- Q

  # compute gradient GRAD of f() at ROT from the gradient Gq of Q at LAMBDA
  # in a manner appropiate for orthogonal or oblique rotation
  if (orthogonal) {
    GRAD <- crossprod(A, Gq)
  } else {
    GRAD <- -1 * solve(t(init.ROT), crossprod(Gq, LAMBDA))
  }

  # start iterations
  converged <- FALSE
  for (iter in seq_len(max.iter + 1L)) {
    # compute projection Gp of GRAD onto the linear manifold tangent at
    # ROT to the manifold of orthogonal or normal (for oblique) matrices
    #
    # this projection is zero if and only if ROT is a stationary point of
    # f() restricted to the orthogonal/normal matrices
    if (orthogonal) {
      MM <- crossprod(ROT, GRAD)
      SYMM <- (MM + t(MM)) / 2
      Gp <- GRAD - (ROT %*% SYMM)
    } else {
      Gp <- GRAD - t(t(ROT) * colSums(ROT * GRAD))
    }

    # check Frobenius norm of Gp
    frob <- sqrt(sum(Gp * Gp))

    # if verbose, print
    if (lav_verbose()) {
      cat(
        "  iter = ", sprintf("%4d", iter - 1),
        " Q = ", sprintf("%9.7f", Q.current),
        " frob.log10 = ", sprintf("%10.7f", log10(frob)),
        " alpha = ", sprintf("%9.7f", alpha), "\n"
      )
    }

    if (frob < gpa.tol) {
      converged <- TRUE
      break
    }

    # update
    alpha <- 2 * alpha
    for (i in seq_len(1000)) { # make option?

      # step in the negative projected gradient direction
      # (note, the original algorithm in Jennrich 2001 used G, not Gp)
      X <- ROT - alpha * Gp

      if (orthogonal) {
        # use SVD to compute the projection ROTt of X onto the manifold
        # of orthogonal matrices
        svd.out <- svd(X)
        U <- svd.out$u
        V <- svd.out$v
        ROTt <- U %*% t(V)
      } else {
        # compute the projection ROTt of X onto the manifold
        # of normal matrices
        v <- 1 / sqrt(apply(X^2, 2, sum))
        ROTt <- X %*% diag(v)
      }

      # rotate again
      if (orthogonal) {
        LAMBDA <- A %*% ROTt
      } else {
        LAMBDA <- t(solve(ROTt, At))
      }

      # evaluate criterion
      Q.new <- do.call(method.fname, c(
        list(LAMBDA = LAMBDA),
        method.args, list(grad = TRUE)
      ))
      Gq <- attr(Q.new, "grad")
      attr(Q.new, "grad") <- NULL

      # check stopping criterion
      if (Q.new < Q.current - 0.5 * frob * frob * alpha) {
        break
      } else {
        alpha <- alpha / 2
      }

      if (i == 1000) {
        lav_msg_warn(gettext("half-stepping failed in GPA"))
      }
    }

    # update
    ROT <- ROTt
    Q.current <- Q.new

    if (orthogonal) {
      GRAD <- crossprod(A, Gq)
    } else {
      GRAD <- -1 * solve(t(ROT), crossprod(Gq, LAMBDA))
    }
  } # iter

  # warn if no convergence
  if (!converged) {
    lav_msg_warn(gettextf(
      "GP rotation algorithm did not converge after %s iterations",
      max.iter
    ))
  }

  # algorithm information
  info <- list(
    algorithm = "gpa",
    iter = iter - 1L,
    converged = converged,
    method.value = Q.current
  )

  attr(ROT, "info") <- info

  ROT
}


# pairwise rotation algorithm with direct line search
#
# based on Kaiser's (1959) algorithm and Jennrich and Sampson (1966) algorithm
# but to make it generic, a line search is used; inspired by Browne 2001
#
# - orthogonal: rotate one pair of columns (=plane) at a time
# - oblique: rotate 1 factor in one pair of columns (=plane) at a time
#            note: in the oblique case, (1,2) is not the same as (2,1)
# - BUT use optimize() to find the optimal angle (for each plane)
#   (see Browne, 2001, page 130)
# - repeat until the changes in the f() criterion are below tol
#

lav_matrix_rotate_pairwise <- function(A = NULL, # original matrix
                                       orthogonal = FALSE,
                                       init.ROT = NULL,
                                       method.fname = NULL, # crit function
                                       method.args = list(), # method args
                                       tol = 1e-8,
                                       max.iter = 1000L) {
  # number of columns
  M <- ncol(A)

  # initial LAMBDA + PHI
  if (is.null(init.ROT)) {
    LAMBDA <- A
    if (!orthogonal) {
      PHI <- diag(M)
    }
  } else {
    if (orthogonal) {
      LAMBDA <- A %*% init.ROT
    } else {
      LAMBDA <- t(solve(init.ROT, t(A)))
      PHI <- crossprod(init.ROT)
    }
  }

  # using the current LAMBDA, evaluate the user-specified
  # rotation criteron; return Q (the criterion) only
  Q.current <- do.call(method.fname, c(
    list(LAMBDA = LAMBDA),
    method.args, list(grad = FALSE)
  ))

  # if verbose, print
  if (lav_verbose()) {
    cat(
      "  iter = ", sprintf("%4d", 0),
      " Q = ", sprintf("%13.11f", Q.current), "\n"
    )
  }

  # plane combinations
  if (orthogonal) {
    PLANE <- utils::combn(M, 2)
  } else {
    tmp <- utils::combn(M, 2)
    PLANE <- cbind(tmp, tmp[c(2, 1), , drop = FALSE])
  }

  # define objective function -- orthogonal
  objf_orth <- function(theta = 0, A = NULL, col1 = 0L, col2 = 0L) {
    # construct ROT
    ROT <- diag(M)
    ROT[col1, col1] <- base::cos(theta)
    ROT[col1, col2] <- base::sin(theta)
    ROT[col2, col1] <- -1 * base::sin(theta)
    ROT[col2, col2] <- base::cos(theta)

    # rotate
    LAMBDA <- A %*% ROT

    # evaluate criterion
    Q <- do.call(method.fname, c(
      list(LAMBDA = LAMBDA),
      method.args, list(grad = FALSE)
    ))

    Q
  }

  # define objective function -- oblique
  objf_obliq <- function(delta = 0, A = NULL, col1 = 0L, col2 = 0L,
                         phi12 = 0) {
    # construct ROT
    ROT <- diag(M)

    # gamma
    gamma2 <- 1 + (2 * delta * phi12) + (delta * delta)

    ROT[col1, col1] <- sqrt(abs(gamma2))
    ROT[col1, col2] <- -1 * delta
    ROT[col2, col1] <- 0
    ROT[col2, col2] <- 1

    # rotate
    LAMBDA <- A %*% ROT

    # evaluate criterion
    Q <- do.call(method.fname, c(
      list(LAMBDA = LAMBDA),
      method.args, list(grad = FALSE)
    ))
    Q
  }

  # start iterations
  converged <- FALSE
  Q.old <- Q.current
  for (iter in seq_len(max.iter)) {
    # rotate - one cycle
    for (pl in seq_len(ncol(PLANE))) {
      # choose plane
      col1 <- PLANE[1, pl]
      col2 <- PLANE[2, pl]

      # optimize
      if (orthogonal) {
        out <- optimize(
          f = objf_orth, interval = c(-pi / 4, +pi / 4),
          A = LAMBDA, col1 = col1, col2 = col2,
          maximum = FALSE, tol = .Machine$double.eps^0.25
        )
        # best rotation - for this plane
        theta <- out$minimum

        # construct ROT
        ROT <- diag(M)
        ROT[col1, col1] <- base::cos(theta)
        ROT[col1, col2] <- base::sin(theta)
        ROT[col2, col1] <- -1 * base::sin(theta)
        ROT[col2, col2] <- base::cos(theta)
      } else {
        phi12 <- PHI[col1, col2]
        out <- optimize(
          f = objf_obliq, interval = c(-1, +1),
          A = LAMBDA, col1 = col1, col2 = col2,
          phi12 = phi12,
          maximum = FALSE, tol = .Machine$double.eps^0.25
        )

        # best rotation - for this plane
        delta <- out$minimum

        # construct ROT
        ROT <- diag(M)

        # gamma
        gamma2 <- 1 + (2 * delta * phi12) + (delta * delta)
        gamma <- sqrt(abs(gamma2))

        ROT[col1, col1] <- gamma
        ROT[col1, col2] <- -1 * delta
        ROT[col2, col1] <- 0
        ROT[col2, col2] <- 1
      }

      # rotate
      LAMBDA <- LAMBDA %*% ROT

      if (!orthogonal) {
        # rotate PHI
        PHI[col1, ] <- (1 / gamma) * PHI[col1, ] + (delta / gamma) * PHI[col2, ]
        PHI[, col1] <- PHI[col1, ]
        PHI[col1, col1] <- 1
      }
    } # all planes

    # check for convergence
    Q.current <- do.call(method.fname, c(
      list(LAMBDA = LAMBDA),
      method.args, list(grad = FALSE)
    ))

    # absolute change in Q
    diff <- abs(Q.old - Q.current)

    # if verbose, print
    if (lav_verbose()) {
      cat(
        "  iter = ", sprintf("%4d", iter),
        " Q = ", sprintf("%13.11f", Q.current),
        " change = ", sprintf("%13.11f", diff), "\n"
      )
    }

    if (diff < tol) {
      converged <- TRUE
      break
    } else {
      Q.old <- Q.current
    }
  } # iter

  # warn if no convergence
  if (!converged) {
    lav_msg_warn(gettextf(
      "pairwise rotation algorithm did not converge after %s iterations",
      max.iter
    ))
  }

  # compute final rotation matrix
  if (orthogonal) {
    ROT <- solve(crossprod(A), crossprod(A, LAMBDA))
  } else {
    # to be compatible with GPa
    ROTt.inv <- solve(crossprod(A), crossprod(A, LAMBDA))
    ROT <- solve(t(ROTt.inv))
  }

  # algorithm information
  info <- list(
    algorithm = "pairwise",
    iter = iter,
    converged = converged,
    method.value = Q.current
  )

  attr(ROT, "info") <- info

  ROT
}

# this code is written by Michael Hallquist
# First draft of parser to convert Mplus model syntax to lavaan model syntax

# idea: build parTable and run model from mplus syntax
# then perhaps write export function: parTable2Mplus
# and/or parTable2lavaan

lav_mplus_trim <- function(string) {
  stringTrim <- sapply(string, function(x) {
    x <- sub("^\\s*", "", x, perl = TRUE)
    x <- sub("\\s*$", "", x, perl = TRUE)
    return(x)
  }, USE.NAMES = FALSE)
  return(stringTrim)
}

# small utility function to join strings in a regexp loop
lav_mplus_join_regex <- function(cmd, argExpand, matches, iterator, matchLength = "match.length") {
  if (iterator == 1 && matches[iterator] > 1) {
    pre <- substr(cmd, 1, matches[iterator] - 1)
  } else {
    pre <- ""
  }

  # if this is not the final match, then get sub-string between the end of this match and the beginning of the next
  # otherwise, match to the end of the command
  post.end <- ifelse(iterator < length(matches), matches[iterator + 1] - 1, nchar(cmd))
  post <- substr(cmd, matches[iterator] + attr(matches, matchLength)[iterator], post.end)

  cmd.expand <- paste(pre, argExpand, post, sep = "")
  return(cmd.expand)
}

# expand Mplus hyphen syntax (will also expand constraints with hyphens)
lav_mplus_expand_cmd <- function(cmd, alphaStart = TRUE) {
  # use negative lookahead and negative lookbehind to eliminate possibility of hyphen being used as a negative starting value (e.g., x*-1)
  # also avoid match of anything that includes a decimal point, such as a floating-point starting value -10.5*x1

  # if alphaStart==TRUE, then require that the matches before and after hyphens begin with alpha character
  # this is used for variable names, whereas the more generic expansion works for numeric constraints and such

  # need to do a better job of this so that u1-u20* is supported... I don't think the regexp below is general enough

  # if (alphaStart) {
  #  hyphens <- gregexpr("[_A-Za-z]+\\w*\\s*-\\s*[_A-Za-z]+\\w*", cmd, perl=TRUE)[[1]]
  # } else {
  #  hyphens <- gregexpr("(?!<(\\*|\\.))\\w+(?!(\\*|\\.))\\s*-\\s*(?!<(\\*|\\.))\\w+(?!(\\*|\\.))", cmd, perl=TRUE)[[1]]
  # }

  # hyphens <- gregexpr("(?!<(\\*|\\.))\\w+(?!(\\*|\\.))\\s*-\\s*(?!<(\\*|\\.))\\w+(?!(\\*|\\.))", cmd, perl=TRUE)[[1]]

  # support trailing @XXX. Still still fail on Trait1-Trait3*XXX
  hyphens <- gregexpr("(?!<(\\*|\\.))\\w+(?!(\\*|\\.))\\s*-\\s*(?!<(\\*|\\.))\\w+(?!(\\*|\\.))(@[\\d\\.\\-]+)?", cmd, perl = TRUE)[[1]]

  # Promising, but this is still failing in the case of x3*1 -4.25*x4
  # On either side of a hyphen, require alpha character followed by alphanumeric
  # This enforces that neither side of the hyphen can be a number
  # Alternatively, match digits on either side alone
  # hyphens <- gregexpr("([A-z]+\\w*\\s*-\\s*[A-z]+\\w*(@[\\d\\.-]+)?|\\d+\\s*-\\s*\\d+)", cmd, perl=TRUE)[[1]]

  if (hyphens[1L] > 0) {
    cmd.expand <- c()
    ep <- 1

    for (v in 1:length(hyphens)) {
      # match one keyword before and after hyphen
      argsplit <- strsplit(substr(cmd, hyphens[v], hyphens[v] + attr(hyphens, "match.length")[v] - 1), "\\s*-\\s*", perl = TRUE)[[1]]

      v_pre <- argsplit[1]
      v_post <- argsplit[2]

      v_post.suffix <- sub("^([^@]+)(@[\\d\\-.]+)?$", "\\2", v_post, perl = TRUE) # will be empty string if not present
      v_post <- sub("@[\\d\\-.]+$", "", v_post, perl = TRUE) # trim @ suffix

      # If v_pre and v_post contain leading alpha characters, verify that these prefixes match.
      # Otherwise, there is nothing to expand, as in the case of MODEL CONSTRAINT: e1e2=e1-e2_n.
      v_pre.alpha <- sub("\\d+$", "", v_pre, perl = TRUE)
      v_post.alpha <- sub("\\d+$", "", v_post, perl = TRUE)

      # only enforce prefix match if we have leading alpha characters (i.e., not simple numeric 1 - 3 syntax)
      if (length(v_pre.alpha) > 0L && length(v_post.alpha) > 0L) {
        # if alpha prefixes do match, assume that the hyphen is not for expansion (e.g., in subtraction case)
        if (v_pre.alpha != v_post.alpha) {
          return(cmd)
        }
      }

      # the basic positive lookbehind blows up with pure numeric constraints (1 - 3) because no alpha char precedes digit
      # can use an non-capturing alternation grouping to allow for digits only or the final digits after alphas (as in v_post.num)
      v_pre.num <- as.integer(sub("\\w*(?<=[A-Za-z_])(\\d+)$", "\\1", v_pre, perl = TRUE)) # use positive lookbehind to avoid greedy \w+ match -- capture all digits

      v_post.match <- regexpr("^(?:\\w*(?<=[A-Za-z_])(\\d+)|(\\d+))$", v_post, perl = TRUE)
      stopifnot(v_post.match[1L] > 0)

      # match mat be under capture[1] or capture[2] because of alternation above
      whichCapture <- which(attr(v_post.match, "capture.start") > 0)

      v_post.num <- as.integer(substr(v_post, attr(v_post.match, "capture.start")[whichCapture], attr(v_post.match, "capture.start")[whichCapture] + attr(v_post.match, "capture.length")[whichCapture] - 1))
      v_post.prefix <- substr(v_post, 1, attr(v_post.match, "capture.start")[whichCapture] - 1) # just trusting that pre and post match

      if (is.na(v_pre.num) || is.na(v_post.num)) lav_msg_stop(
        gettext("Cannot expand variables:"), v_pre, ", ", v_post)
      v_expand <- paste(v_post.prefix, v_pre.num:v_post.num, v_post.suffix, sep = "", collapse = " ")

      # for first hyphen, there may be non-hyphenated syntax preceding the initial match
      cmd.expand[ep] <- lav_mplus_join_regex(cmd, v_expand, hyphens, v)

      # This won't really work because the cmd.expand element may contain other variables
      # that are at the beginning or end, prior to hyphen stuff
      # This is superseded by logic above where @ is included in hyphen match, then trapped as suffix
      # I don't think it will work yet for this Mplus syntax: y1-y10*5 -- the 5 wouldn't propagate
      # handle the case of @ fixed values or * starting values used in a list
      # example: Trait1-Trait3@1
      ## if (grepl("@|\\*", cmd.expand[ep], perl=TRUE)) {
      ##   exp_split <- strsplit(cmd.expand[ep], "\\s+", perl=TRUE)[[1]]
      ##   suffixes <- sub("^([^@\\*]+)([@*][\\d\\.-]+)?$", "\\2", exp_split, perl=TRUE)
      ##   variables <- sub("^([^@\\*]+)([@*][\\d\\.-]+)?$", "\\1", exp_split, perl=TRUE)
      ##   suffixes <- suffixes[suffixes != ""]
      ##   if (length(unique(suffixes)) > 1L) {
      ##     browser()

      ##     #stop("Don't know how to interpret syntax: ", cmd)
      ##   } else {
      ##     variables <- paste0(variables, suffixes[1])
      ##     cmd.expand[ep] <- paste(variables, collapse=" ")
      ##   }
      ## }

      ep <- ep + 1
    }
    return(paste(cmd.expand, collapse = ""))
  } else {
    return(cmd) # no hyphens to expand
  }
}


# handle starting values and fixed parameters on rhs
lav_mplus_cmd_fix_start <- function(cmd) {
  cmd.parse <- c()
  ep <- 1L

  # support ESEM-like syntax: F BY a1* a2*
  # The easy path: putting in 1s before we proceed on parsing
  # Mar2023 bugfix: support parenthesis after * in case a parameter constraint comes next
  cmd <- gsub("([A-z]+\\w*)\\s*\\*(?=\\s+\\(?[A-z]+|\\s*$)", "\\1*1", cmd, perl = TRUE)

  if ((fixed.starts <- gregexpr("[\\w\\.\\-$]+\\s*([@*])\\s*[\\w\\.\\-]+", cmd, perl = TRUE)[[1]])[1L] > 0) { # shouldn't it be \\*, not * ?! Come back to this.
    for (f in 1:length(fixed.starts)) {
      # capture above obtains the fixed/start character (@ or *), whereas match obtains the full regex match
      opchar <- substr(cmd, attr(fixed.starts, "capture.start")[f], attr(fixed.starts, "capture.start")[f] + attr(fixed.starts, "capture.length")[f] - 1)

      # match arguments around asterisk/at symbol
      argsplit <- strsplit(substr(cmd, fixed.starts[f], fixed.starts[f] + attr(fixed.starts, "match.length")[f] - 1), paste0("\\s*", ifelse(opchar == "*", "\\*", opchar), "\\s*"), perl = TRUE)[[1]]
      v_pre <- argsplit[1]
      v_post <- argsplit[2]

      if (suppressWarnings(is.na(as.numeric(v_pre)))) { # fixed.starts value post-multiplier
        var <- v_pre
        val <- v_post
      } else if (suppressWarnings(is.na(as.numeric(v_post)))) { # starting value pre-multiplier
        var <- v_post
        val <- v_pre
      } else {
        lav_msg_stop(
          gettext("Cannot parse Mplus fixed/starts values specification:"),
          v_pre, v_post)
      }

      if (opchar == "@") {
        cmd.parse[ep] <- lav_mplus_join_regex(cmd, paste0(val, "*", var, sep = ""), fixed.starts, f)
        ep <- ep + 1L
      } else {
        cmd.parse[ep] <- lav_mplus_join_regex(cmd, paste0("start(", val, ")*", var, sep = ""), fixed.starts, f)
        ep <- ep + 1L
      }
    }
    return(paste(cmd.parse, collapse = ""))
  } else {
    return(cmd)
  }
}

lav_mplus_cmd_constraints <- function(cmd) {
  # Allow cmd to have newlines embedded. In this case, split on newlines, and loop over and parse each chunk
  # Dump leading and trailing newlines, which contain no information about constraints, but may add dummy elements to vector after strsplit
  # Maybe return LHS and RHS parsed command where constraints only appear on the RHS, whereas the LHS contains only parameters.
  # Example: LHS is v1 v2 v3 and RHS is con1*v1 con2*v2 con3*v3

  cmd.split <- strsplit(cmd, "\n")[[1]]

  # drop empty lines (especially leading newline)
  cmd.split <- if (length(emptyPos <- which(cmd.split == "")) > 0L) {
    cmd.split[-1 * emptyPos]
  } else {
    cmd.split
  }

  # Create a version of the command with no modifiers (constraints, starting values, etc.) specifications.
  # This is useful for syntax that uses the params on the LHS and with a modified RHS. Example: v1 ~~ conB*v1
  cmd.nomodifiers <- paste0(gsub("(start\\([^\\)]+\\)\\*|[\\d\\-\\.]+\\*)", "", cmd.split, perl = TRUE), collapse = " ") # peel off premultiplication
  cmd.nomodifiers <- gsub("\\([^\\)]+\\)", "", cmd.nomodifiers, perl = TRUE)

  cmd.tojoin <- c() # will store all chunks divided by newlines, which will be joined at the end.

  # iterate over each newline segment
  for (n in 1:length(cmd.split)) {
    # in principle, now that we respect newlines, parens should only be of length 1, since Mplus syntax dictates newlines for each use of parentheses for constraints
    if ((parens <- gregexpr("(?<!start)\\(([^\\)]+)\\)", cmd.split[n], perl = TRUE)[[1L]])[1L] > 0) { # match parentheses, but not start()
      # the syntax chunk after all parentheses have been matched
      cmd.expand <- c()

      for (p in 1:length(parens)) {
        # string within the constraint parentheses
        constraints <- substr(cmd.split[n], attr(parens, "capture.start")[p], attr(parens, "capture.start")[p] + attr(parens, "capture.length")[p] - 1)

        # Divide constraints on spaces to determine number of constraints to parse. Use lav_mplus_trim to avoid problem of user including leading/trailing spaces within parentheses.
        con.split <- strsplit(lav_mplus_trim(constraints), "\\s+", perl = TRUE)[[1]]

        # if Mplus uses a purely numeric constraint, then add ".con" prefix to be consistent with R naming.
        con.split <- sapply(con.split, function(x) {
          if (!suppressWarnings(is.na(as.numeric(x)))) {
            make.names(paste0(".con", x))
          } else {
            x
          }
        })

        # determine the parameters that precede the parentheses (either first character for p == 1 or character after preceding parentheses)
        prestrStart <- ifelse(p > 1, attr(parens, "capture.start")[p - 1] + attr(parens, "capture.length")[p - 1] + 1, 1)

        # obtain the parameters that precede the parentheses, divide into arguments on spaces
        # use lav_mplus_trim here because first char after prestrStart for p > 1 will probably be a space
        precmd.split <- strsplit(lav_mplus_trim(substr(cmd.split[n], prestrStart, parens[p] - 1)), "\\s+", perl = TRUE)[[1]]

        # peel off any potential LHS arguments, such as F1 BY
        precmdLHSOp <- which(tolower(precmd.split) %in% c("by", "with", "on"))
        if (any(precmdLHSOp)) {
          lhsop <- paste0(precmd.split[1:precmdLHSOp[1L]], " ", collapse = " ") # join lhs and op as a single string, add trailing space so that paste with expanded RHS is right.
          rhs <- precmd.split[(precmdLHSOp + 1):length(precmd.split)]
        } else {
          lhsop <- ""
          rhs <- precmd.split
        }

        if (length(con.split) > 1L) {
          # several constraints listed within parentheses. Example: F1 BY X1 X2 X3 X4 (C2 C3 C4)
          # thus, backwards match the constraints to parameters

          # restrict parameters to backwards match to be of the same length as number of constraints
          rhs.backmatch <- rhs[(length(rhs) - length(con.split) + 1):length(rhs)]

          rhs.expand <- c()

          # check that no mean or scale markers are part of the rhs param to expand
          if ((preMark.match <- regexpr("^\\s*[\\[\\{]", rhs.backmatch[1L], perl = TRUE))[1L] > 0) {
            preMark <- substr(rhs.backmatch[1L], preMark.match[1L], preMark.match[1L] + attr(preMark.match, "match.length")[1L] - 1)
            rhs.backmatch[1L] <- substr(rhs.backmatch[1L], preMark.match[1L] + attr(preMark.match, "match.length")[1L], nchar(rhs.backmatch[1L]))
          } else {
            preMark <- ""
          }

          if ((postMark.match <- regexpr("[\\]\\}]\\s*$", rhs.backmatch[length(rhs.backmatch)], perl = TRUE))[1L] > 0) {
            postMark <- substr(rhs.backmatch[length(rhs.backmatch)], postMark.match[1L], nchar(rhs.backmatch[length(rhs.backmatch)]))
            rhs.backmatch[length(rhs.backmatch)] <- substr(rhs.backmatch[length(rhs.backmatch)], 1, postMark.match[1L] - 1)
          } else {
            postMark <- ""
          }


          # pre-multiply each parameter with each corresponding constraint
          for (i in 1:length(rhs.backmatch)) {
            rhs.expand[i] <- paste0(con.split[i], "*", rhs.backmatch[i])
          }

          # join rhs as string and add back in mean/scale operator, if present
          rhs.expand <- paste0(preMark, paste(rhs.expand, collapse = " "), postMark)

          # if there were params that preceded the backwards match, then add these back to the syntax
          # append this syntax to the parsed command, cmd.expand
          if (length(rhs) - length(con.split) > 0L) {
            cmd.expand <- c(cmd.expand, paste(lhsop, paste(rhs[1:(length(rhs) - length(con.split))], collapse = " "), rhs.expand))
          } else {
            cmd.expand <- c(cmd.expand, paste0(lhsop, rhs.expand))
          }
        } else {
          # should be able to reduce redundancy with above

          # all parameters on the right hand side are to be equated
          # thus, pre-multiply each parameter by the constraint

          # check that no mean or scale markers are part of the rhs param to expand
          # DUPE CODE FROM ABOVE. Make Function?!
          if ((preMark.match <- regexpr("^\\s*[\\[\\{]", rhs[1L], perl = TRUE))[1L] > 0) {
            preMark <- substr(rhs[1L], preMark.match[1L], preMark.match[1L] + attr(preMark.match, "match.length")[1L] - 1)
            rhs[1L] <- substr(rhs[1L], preMark.match[1L] + attr(preMark.match, "match.length")[1L], nchar(rhs[1L]))
          } else {
            preMark <- ""
          }

          if ((postMark.match <- regexpr("[\\]\\}]\\s*$", rhs[length(rhs)], perl = TRUE))[1L] > 0) {
            postMark <- substr(rhs[length(rhs)], postMark.match[1L], nchar(rhs[length(rhs)]))
            rhs[length(rhs)] <- substr(rhs[length(rhs)], 1, postMark.match[1L] - 1)
          } else {
            postMark <- ""
          }


          rhs.expand <- c()
          for (i in 1:length(rhs)) {
            rhs.expand[i] <- paste0(con.split[1L], "*", rhs[i])
          }

          # join rhs as string
          rhs.expand <- paste0(preMark, paste(rhs.expand, collapse = " "), postMark)

          cmd.expand <- c(cmd.expand, paste0(lhsop, rhs.expand))
        }
      }

      cmd.tojoin[n] <- paste(cmd.expand, collapse = " ")
    } else {
      cmd.tojoin[n] <- cmd.split[n]
    } # no parens
  }

  # eliminate newlines in this function so that they don't mess up \\s+ splits downstream
  toReturn <- paste(cmd.tojoin, collapse = " ")
  attr(toReturn, "noModifiers") <- cmd.nomodifiers

  return(toReturn)
}

lav_mplus_cmd_growth <- function(cmd) {
  # can assume that any spaces between tscore and variable were stripped by lav_mplus_cmd_fix_start

  # verify that this is not a random slope
  if (any(tolower(strsplit(cmd, "\\s+", perl = TRUE)[[1]]) %in% c("on", "at"))) {
    lav_msg_stop(gettext(
      "lavaan does not support random slopes or individually varying
      growth model time scores"))
  }

  cmd.split <- strsplit(cmd, "\\s*\\|\\s*", perl = TRUE)[[1]]
  if (!length(cmd.split) == 2) {
    lav_msg_stop(gettext("Unknown growth syntax:"), cmd)
  }

  lhs <- cmd.split[1]
  lhs.split <- strsplit(lhs, "\\s+", perl = TRUE)[[1]]

  rhs <- cmd.split[2]
  rhs.split <- strsplit(rhs, "(\\*|\\s+)", perl = TRUE)[[1]]

  if (length(rhs.split) %% 2 != 0) {
    lav_msg_stop(gettext(
      "Number of variables and number of tscores does not match:"), rhs)
  }
  tscores <- as.numeric(rhs.split[1:length(rhs.split) %% 2 != 0]) # pre-multipliers

  vars <- rhs.split[1:length(rhs.split) %% 2 == 0]

  cmd.expand <- c()

  for (p in 0:(length(lhs.split) - 1)) {
    if (p == 0) {
      # intercept
      cmd.expand <- c(cmd.expand, paste(lhs.split[(p + 1)], "=~", paste("1*", vars, sep = "", collapse = " + ")))
    } else {
      cmd.expand <- c(cmd.expand, paste(lhs.split[(p + 1)], "=~", paste(tscores^p, "*", vars, sep = "", collapse = " + ")))
    }
  }

  return(cmd.expand)
}

# function to wrap long lines at a certain width, splitting on + symbols to be consistent with R syntax
lav_mplus_cmd_wrap <- function(cmd, width = 90, exdent = 5) {
  result <- lapply(cmd, function(line) {
    if (nchar(line) > width) {
      split <- c()
      spos <- 1L

      plusMatch <- gregexpr("+", line, fixed = TRUE)[[1]]
      mpos <- 1L

      if (plusMatch[1L] > 0L) {
        # split after plus symbol
        charsRemain <- nchar(line)
        while (charsRemain > 0L) {
          toProcess <- substr(line, nchar(line) - charsRemain + 1, nchar(line))
          offset <- nchar(line) - charsRemain + 1

          if (nchar(remainder <- substr(line, offset, nchar(line))) <= (width - exdent)) {
            # remainder of line fits within width -- no need to continue wrapping
            split[spos] <- remainder
            charsRemain <- 0
          } else {
            wrapAt <- which(plusMatch < (width + offset - exdent))
            wrapAt <- wrapAt[length(wrapAt)] # at the final +

            split[spos] <- substr(line, offset, plusMatch[wrapAt])
            charsRemain <- charsRemain - nchar(split[spos])
            spos <- spos + 1
          }
        }

        # remove leading and trailing chars
        split <- lav_mplus_trim(split)

        # handle exdent
        split <- sapply(1:length(split), function(x) {
          if (x > 1) {
            paste0(paste(rep(" ", exdent), collapse = ""), split[x])
          } else {
            split[x]
          }
        })

        return(split)
      } else {
        return(strwrap(line, width = width, exdent = exdent)) # convention strwrap when no + present
      }
    } else {
      return(line)
    }
  })

  # bind together multi-line expansions into single vector
  return(unname(do.call(c, result)))
}

lav_mplus_syntax_constraints <- function(syntax) {
  # should probably pass in model syntax along with some tracking of which parameter labels are defined.

  # convert MODEL CONSTRAINT section to lavaan model syntax
  syntax <- paste(lapply(lav_mplus_trim(strsplit(syntax, "\n")), function(x) {
    if (length(x) == 0L && is.character(x)) "" else x
  }), collapse = "\n")

  # replace ! with # for comment lines. Also strip newline and replace with semicolon
  syntax <- gsub("(\\s*)!(.+)\n", "\\1#\\2;", syntax, perl = TRUE)

  # split into vector of strings
  # need to peel off leading or trailing newlines -- leads to parsing confusion downstream otherwise
  syntax.split <- gsub("(^\n|\n$)", "", unlist(strsplit(syntax, ";")), perl = TRUE)

  constraint.out <- c()

  # TODO: Handle PLOT and LOOP syntax for model constraints.
  # TODO: Handle DO loop convention

  # first parse new parameters defined in MODEL CONSTRAINT into a vector
  new.parameters <- c() # parameters that are defined in constraint section
  if (length(new.con.lines <- grep("^\\s*NEW\\s*\\([^\\)]+\\)", syntax.split, perl = TRUE, ignore.case = TRUE)) > 0L) {
    for (cmd in syntax.split[new.con.lines]) {
      # process new constraint definition
      new.con <- regexpr("^\\s*NEW\\s*\\(([^\\)]+)\\)", cmd, perl = TRUE, ignore.case = TRUE)
      if (new.con[1L] == -1)
        lav_msg_stop(gettext("Unable to parse names of new contraints"))
      new.con <- substr(cmd, attr(new.con, "capture.start"), attr(new.con, "capture.start") + attr(new.con, "capture.length") - 1L)
      new.con <- lav_mplus_expand_cmd(new.con) # allow for hyphen expansion
      new.parameters <- c(new.parameters, strsplit(lav_mplus_trim(new.con), "\\s+", perl = TRUE)[[1L]])
    }

    syntax.split <- syntax.split[-1L * new.con.lines] # drop out these lines
    parameters.undefined <- new.parameters # to be used below to handle ambiguity of equation versus definition
  }

  for (cmd in syntax.split) {
    if (grepl("^\\s*#", cmd, perl = TRUE)) { # comment line
      constraint.out <- c(constraint.out, gsub("\n", "", cmd, fixed = TRUE)) # drop any newlines
    } else if (grepl("^\\s+$", cmd, perl = TRUE)) {
      # do nothing, just a space line
    } else {
      # constraint proper
      cmd <- gsub("**", "^", cmd, fixed = TRUE) # handle exponent

      # lower case the math operations supported by Mplus to be consistent with R
      # match all math operators, then lower case each and rejoin string
      maths <- gregexpr("(SQRT|LOG|LOG10|EXP|ABS|SIN|COS|TAN|ASIN|ACOS|ATAN)\\s*\\(", cmd, perl = TRUE)[[1L]]
      if (maths[1L] > 0) {
        maths.replace <- c()
        ep <- 1

        for (i in 1:length(maths)) {
          operator <- tolower(substr(cmd, attr(maths, "capture.start")[i], attr(maths, "capture.start")[i] + attr(maths, "capture.length")[i] - 1))
          maths.replace[ep] <- lav_mplus_join_regex(cmd, operator, maths, i, matchLength = "capture.length") # only match operator, not opening (
          ep <- ep + 1
        }
        cmd <- paste(maths.replace, collapse = "")
      }

      # equating some lhs and rhs: could reflect definition of new parameter
      if ((equals <- regexpr("=", cmd, fixed = TRUE))[1L] > 0) {
        lhs <- lav_mplus_trim(substr(cmd, 1, equals - 1))
        rhs <- lav_mplus_trim(substr(cmd, equals + attr(equals, "match.length"), nchar(cmd)))

        # possibility of lhs or rhs containing the single variable to be equated
        if (regexpr("\\s+", lhs, perl = TRUE)[1L] > 0L) {
          def <- rhs
          body <- lhs
        } else if (regexpr("\\s+", rhs, perl = TRUE)[1L] > 0L) {
          def <- lhs
          body <- rhs
        } else {
          # warning("Can't figure out which side of constraint defines a parameter")
          # this would occur for simple rel5 = rel2 sort of syntax
          def <- lhs
          body <- rhs
        }

        # must decide whether this is a new parameter (:=) or equation of exising labels (==)
        # alternatively, could be zero, as in  0 = x + y
        # this is tricky, because mplus doesn't differentiate definition from equation
        # consequently, could confuse the issue as in ex5.20
        # NEW(rel2 rel5 stan3 stan6);
        # rel2 = lam2**2*vf1/(lam2**2*vf1 + ve2);
        # rel5 = lam5**2*vf2/(lam5**2*vf2 + ve5);
        # rel5 = rel2;

        # for now, only define a new constraint if it's not already defined
        # otherwise equate
        if (def %in% new.parameters && def %in% parameters.undefined) {
          constraint.out <- c(constraint.out, paste(def, ":=", body))
          parameters.undefined <- parameters.undefined[!parameters.undefined == def]
        } else {
          constraint.out <- c(constraint.out, paste(def, "==", body))
        }
      } else {
        # inequality constraints -- paste as is
        constraint.out <- c(constraint.out, cmd)
      }
    }
  }

  wrap <- paste(lav_mplus_cmd_wrap(constraint.out, width = 90, exdent = 5), collapse = "\n")
  return(wrap)
}

lav_mplus_syntax_model <- function(syntax) {
  if (is.character(syntax)) {
    if (length(syntax) > 1L) {
      syntax <- paste(syntax, collapse = "\n")
    } # concatenate into a long string separated by newlines
  } else {
    lav_msg_stop(gettext(
      "lav_mplus_syntax_model accepts a single character string or
      character vector containing all model syntax"))
  }

  # because this is now exposed as a function in the package, handle the case of the user passing in full .inp file as text
  # we should only be interested in the MODEL and MODEL CONSTRAINT sections
  by_line <- strsplit(syntax, "\r?\n", perl = TRUE)[[1]]
  inputHeaders <- grep("^\\s*(title:|data.*:|variable:|define:|analysis:|model.*:|output:|savedata:|plot:|montecarlo:)", by_line, ignore.case = TRUE, perl = TRUE)
  con_syntax <- c()
  if (length(inputHeaders) > 0L) {
    # warning("lav_mplus_syntax_model is intended to accept only the model section, not an entire .inp file. For the .inp file case, use lav_mplus_lavaan")
    parsed_syntax <- lav_mplus_text_sections(by_line, "local")

    # handle model constraint
    if ("model.constraint" %in% names(parsed_syntax)) {
      con_syntax <- strsplit(lav_mplus_syntax_constraints(parsed_syntax$model.constraint), "\n")[[1]]
    }

    # just keep model syntax before continuing
    syntax <- parsed_syntax$model
  }

  # initial strip of leading/trailing whitespace, which can interfere with splitting on spaces
  # strsplit generates character(0) for empty strings, which causes problems in paste because paste actually includes it as a literal
  # example: paste(list(character(0), "asdf", character(0)), collapse=" ")
  # thus, use lapply to convert these to empty strings first
  syntax <- paste(lapply(lav_mplus_trim(strsplit(syntax, "\n")), function(x) {
    if (length(x) == 0L && is.character(x)) "" else x
  }), collapse = "\n")

  # replace ! with # for comment lines. Also strip newline and replace with semicolon
  syntax <- gsub("(\\s*)!(.+)\n*", "\\1#\\2;", syntax, perl = TRUE)

  # new direction: retain newlines in parsed syntax until after constraints have been parsed

  # delete newlines
  # syntax <- gsub("\n", "", syntax, fixed=TRUE)

  # replace semicolons with newlines prior to split (divide into commands)
  # syntax <- gsub(";", "\n", syntax, fixed=TRUE)

  # split into vector of strings
  # syntax.split <- unlist( strsplit(syntax, "\n") )
  syntax.split <- lav_mplus_trim(unlist(strsplit(syntax, ";")))

  # format of parTable to mimic.
  # 'data.frame':	34 obs. of  12 variables:
  #  $ id    : int  1 2 3 4 5 6 7 8 9 10 ...
  #  $ lhs   : chr  "ind60" "ind60" "ind60" "dem60" ...
  #  $ op    : chr  "=~" "=~" "=~" "=~" ...
  #  $ rhs   : chr  "x1" "x2" "x3" "y1" ...
  #  $ user  : int  1 1 1 1 1 1 1 1 1 1 ...
  #  $ group : int  1 1 1 1 1 1 1 1 1 1 ...
  #  $ free  : int  0 1 2 0 3 4 5 0 6 7 ...
  #  $ ustart: num  1 NA NA 1 NA NA NA 1 NA NA ...
  #  $ exo   : int  0 0 0 0 0 0 0 0 0 0 ...
  #  $ label : chr  "" "" "" "" ...
  #  $ eq.id : int  0 0 0 0 0 0 0 0 0 0 ...
  #  $ unco  : int  0 1 2 0 3 4 5 0 6 7 ...

  # vector of lavaan syntax
  lavaan.out <- c()

  for (cmd in syntax.split) {
    if (grepl("^\\s*#", cmd, perl = TRUE)) { # comment line
      lavaan.out <- c(lavaan.out, gsub("\n", "", cmd, fixed = TRUE)) # drop any newlines (otherwise done by lav_mplus_cmd_constraints)
    } else if (grepl("^\\s*$", cmd, perl = TRUE)) {
      # do nothing, just a space or blank line
    } else {
      # hyphen expansion
      cmd <- lav_mplus_expand_cmd(cmd)

      # parse fixed parameters and starting values
      cmd <- lav_mplus_cmd_fix_start(cmd)

      # parse any constraints here (avoid weird logic below)
      cmd <- lav_mplus_cmd_constraints(cmd)

      if ((op <- regexpr("\\s+(by|on|with|pwith)\\s+", cmd, ignore.case = TRUE, perl = TRUE))[1L] > 0) { # regressions, factors, covariances

        lhs <- substr(cmd, 1, op - 1) # using op takes match.start which will omit spaces before operator
        rhs <- substr(cmd, op + attr(op, "match.length"), nchar(cmd))
        operator <- tolower(substr(cmd, attr(op, "capture.start"), attr(op, "capture.start") + attr(op, "capture.length") - 1))

        if (operator == "by") {
          lav.operator <- "=~"
        } else if (operator == "with" || operator == "pwith") {
          lav.operator <- "~~"
        } else if (operator == "on") {
          lav.operator <- "~"
        }

        # handle parameter combinations
        lhs.split <- strsplit(lhs, "\\s+")[[1]] # lav_mplus_trim(

        # handle pwith syntax
        if (operator == "pwith") {
          # TODO: Figure out if pwith can be paired with constraints?

          rhs.split <- strsplit(rhs, "\\s+")[[1]] # lav_mplus_trim(
          if (length(lhs.split) != length(rhs.split)) {
            browser()
            lav_msg_stop(gettext(
              "PWITH command does not have the same number of arguments on
              the left and right sides."))
          }

          cmd <- sapply(1:length(lhs.split), function(i) paste(lhs.split[i], lav.operator, rhs.split[i]))
        } else {
          # insert plus signs on the rhs as long as it isn't preceded or followed by a plus already
          rhs <- gsub("(?<!\\+)\\s+(?!\\+)", " + ", rhs, perl = TRUE)

          if (length(lhs.split) > 1L) {
            # expand using possible combinations
            cmd <- sapply(lhs.split, function(larg) {
              pair <- paste(larg, lav.operator, rhs)
              return(pair)
            })
          } else {
            cmd <- paste(lhs, lav.operator, rhs)
          }
        }
      } else if ((means.scales <- regexpr("^\\s*([\\[\\{])([^\\]\\}]+)[\\]\\}]\\s*$", cmd, ignore.case = TRUE, perl = TRUE))[1L] > 0) { # intercepts/means or scales
        # first capture is the operator: [ or {
        operator <- substr(cmd, attr(means.scales, "capture.start")[1L], attr(means.scales, "capture.start")[1L] + attr(means.scales, "capture.length")[1L] - 1)

        params <- substr(cmd, attr(means.scales, "capture.start")[2L], attr(means.scales, "capture.start")[2L] + attr(means.scales, "capture.length")[2L] - 1)

        # obtain parameters with no modifiers specified for LHS
        params.noModifiers <- sub("^\\s*[\\[\\{]([^\\]\\}]+)[\\]\\}]\\s*$", "\\1", attr(cmd, "noModifiers"), perl = TRUE)

        means.scales.split <- strsplit(params, "\\s+")[[1]] # lav_mplus_trim(
        means.scales.noModifiers.split <- strsplit(params.noModifiers, "\\s+")[[1]] # lav_mplus_trim(

        if (operator == "[") {
          # Tricky syntax shift (and corresponding kludge). For means, need to put constraint on RHS as pre-multiplier of 1 (e.g., x1 ~ 5*1).
          # But lav_mplus_cmd_constraints returns constraints multiplied by parameters
          cmd <- sapply(means.scales.split, function(v) {
            # shift pre-multiplier
            if ((premult <- regexpr("([^\\*]+\\*[^\\*]+)\\*([^\\*]+)", v, perl = TRUE))[1L] > 0) { # double modifier: label and constraint
              modifier <- substr(v, attr(premult, "capture.start")[1L], attr(premult, "capture.start")[1L] + attr(premult, "capture.length")[1L] - 1)
              paramName <- substr(v, attr(premult, "capture.start")[2L], attr(premult, "capture.start")[2L] + attr(premult, "capture.length")[2L] - 1)
              paste0(paramName, " ~ ", modifier, "*1")
            } else if ((premult <- regexpr("([^\\*]+)\\*([^\\*]+)", v, perl = TRUE))[1L] > 0) {
              modifier <- substr(v, attr(premult, "capture.start")[1L], attr(premult, "capture.start")[1L] + attr(premult, "capture.length")[1L] - 1)
              paramName <- substr(v, attr(premult, "capture.start")[2L], attr(premult, "capture.start")[2L] + attr(premult, "capture.length")[2L] - 1)
              paste0(paramName, " ~ ", modifier, "*1")
            } else {
              paste(v, "~ 1")
            }
          })
        } else if (operator == "{") {
          # only include constraints on RHS
          cmd <- sapply(1:length(means.scales.split), function(v) paste(means.scales.noModifiers.split[v], "~*~", means.scales.split[v]))
        } else {
          lav_msg_stop(gettext("What's the operator?!"))
        }
      } else if (grepl("|", cmd, fixed = TRUE)) {
        # expand growth modeling language
        cmd <- lav_mplus_cmd_growth(cmd)
      } else { # no operator, no means, must be variance.
        # cat("assuming vars: ", cmd, "\n")

        vars.lhs <- strsplit(attr(cmd, "noModifiers"), "\\s+")[[1]] # lav_mplus_trim(
        vars.rhs <- strsplit(cmd, "\\s+")[[1]] # lav_mplus_trim(

        cmd <- sapply(1:length(vars.lhs), function(v) paste(vars.lhs[v], "~~", vars.rhs[v]))
      }

      # handle threshold substitution: $ -> |
      cmd <- gsub("$", "|", cmd, fixed = TRUE)

      # if we have both starting/fixed values and constraints, these must be handled by separate commands.
      # starting and fixed values are already handled in the pipeline by this point, so should be evident in the command
      # bfi BY lab1*start(1)*bfi_1 ==> bfi BY lab1*bfi_1 + start(1)*bfi_1
      double_asterisks <- grepl("\\s*[\\w\\(\\)\\.]+\\*[\\w\\(\\)\\.]+\\*[\\w\\(\\)\\.]+", cmd, perl = TRUE)

      if (isTRUE(double_asterisks[1])) {
        ss <- strsplit(cmd, "*", fixed = TRUE)[[1]]
        if (length(ss) != 3) {
          lav_msg_warn(gettext("problem interpreting double asterisk syntax:"),
                       cmd) # sanity check on my logic
        } else {
          cmd <- paste0(ss[1], "*", ss[3], " + ", ss[2], "*", ss[3])
        }
      }

      lavaan.out <- c(lavaan.out, cmd)
    }
  }

  # new threshold syntax shifts things to the form:
  # VAR | t1 + t2 + t3 (left to write ordering)
  # Parameter labels, fixed values, and starting values are tacked on in the usual way, like
  # VAR | 5*t1 + start(1.5)*t2 + par_label*t3 (left to write ordering)

  thresh_lines <- grep("^\\s*[A-z]+\\w*\\|\\d+", lavaan.out, perl = TRUE)
  if (length(thresh_lines) > 0L) {
    thresh_vars <- unname(sub("^\\s*([A-z]+\\w*).*", "\\1", lavaan.out[thresh_lines], perl = TRUE))
    thresh_split <- split(thresh_lines, thresh_vars)
    drop_elements <- c()
    for (i in seq_along(thresh_split)) {
      this_set <- lavaan.out[thresh_split[[i]]]
      tnum <- as.integer(sub("^\\s*[A-z]+\\w*\\|(\\d+)\\s*.*", "\\1", this_set))
      this_set <- this_set[order(tnum)] # ensure that threshold numbering matches ascending order
      this_set <- sub("[^~]+\\s*~\\s*", "", this_set, perl = T) # drop variable and ~

      # convert to new t1, t2 syntax by combining modifiers with threshold numbers
      this_set <- sapply(seq_along(this_set), function(j) {
        # gsub("[^~]+\\s*~\\s*([\\w\\.\\-]+\\*)*1", paste0("\\1t", j), this_set[j], perl=TRUE)
        gsub("([\\w\\.\\-]+\\*)*1", paste0("\\1t", j), this_set[j], perl = TRUE)
      })

      new_str <- paste(names(thresh_split)[i], "|", paste(this_set, collapse = " + "))
      # replace in model string on the first line having relevant syntax
      lavaan.out[thresh_split[[i]][1]] <- new_str
      drop_elements <- c(drop_elements, thresh_split[[i]][-1])
    }
    lavaan.out <- lavaan.out[-drop_elements]
  }


  # tack on constraint syntax, if included
  lavaan.out <- c(lavaan.out, con_syntax)

  # for now, include a final lav_mplus_trim call since some arguments have leading/trailing space stripped.
  wrap <- paste(lav_mplus_cmd_wrap(lavaan.out, width = 90, exdent = 5), collapse = "\n") # lav_mplus_trim(
  return(wrap)
}

lav_mplus_lavaan <- function(inpfile, run = TRUE) {
  stopifnot(length(inpfile) == 1L)
  stopifnot(grepl("\\.inp$", inpfile, ignore.case = TRUE))
  if (!file.exists(inpfile)) {
    lav_msg_stop(gettext("Could not find file:"), inpfile)
  }

  # for future consideration. For now, require a .inp file
  #  if (length(inpfile) == 1L && grepl("\\.inp$", inpfile)) {
  #    if (!file.exists(inpfile)) { stop("Could not find file: ", inpfile) }
  #    inpfile.text <- scan(inpfile, what="character", sep="\n", strip.white=FALSE, blank.lines.skip=FALSE, quiet=TRUE)
  #  } else {
  #    #assume that inpfile itself is syntax (e.g., in a character vector)
  #    inpfile.text <- inpfile
  #  }

  inpfile.text <- scan(inpfile, what = "character", sep = "\n", strip.white = FALSE, blank.lines.skip = FALSE, quiet = TRUE)
  sections <- lav_mplus_text_sections(inpfile.text, inpfile)

  mplus.inp <- list()

  mplus.inp$title <- lav_mplus_trim(paste(sections$title, collapse = " "))
  mplus.inp$data <- lav_mplus_text_fields(sections$data, required = "file")
  mplus.inp$variable <- lav_mplus_text_fields(sections$variable, required = "names")
  mplus.inp$analysis <- lav_mplus_text_fields(sections$analysis)

  meanstructure <- "default" # lavaan default
  if (!is.null(mplus.inp$analysis$model)) {
    if (tolower(mplus.inp$analysis$model) == "nomeanstructure") {
      meanstructure <- FALSE
    } # explicitly disable mean structure
  }

  information <- "default" # lavaan default
  if (!is.null(mplus.inp$analysis$information)) {
    information <- tolower(mplus.inp$analysis$information)
  }

  estimator <- "default"
  if (!is.null(est <- mplus.inp$analysis$estimator)) {
    # no memory of what this is up to....
    if (toupper(est) == "MUML") lav_msg_warn(gettext(
      "Mplus does not support MUML estimator. Using default instead."))
    estimator <- est

    # march 2013: handle case where categorical data are specified, but ML-based estimator requested.
    # use WLSMV instead
    if (!is.null(mplus.inp$variable$categorical) && toupper(substr(mplus.inp$analysis$estimator, 1, 2)) == "ML") {
      lav_msg_warn(gettext(
        "Lavaan does not yet support ML-based estimation for categorical data.
        Reverting to WLSMV"))
      estimator <- "WLSMV"
    }
  }

  # expand hyphens in variable names and split into vector that will be the names for read.table
  mplus.inp$variable$names <- strsplit(lav_mplus_expand_cmd(mplus.inp$variable$names), "\\s+", perl = TRUE)[[1]]

  # expand hyphens in categorical declaration
  if (!is.null(mplus.inp$variable$categorical)) mplus.inp$variable$categorical <- strsplit(lav_mplus_expand_cmd(mplus.inp$variable$categorical), "\\s+", perl = TRUE)[[1]]

  # convert mplus syntax to lavaan syntax
  mplus.inp$model <- lav_mplus_syntax_model(sections$model)

  # handle model constraint
  if ("model.constraint" %in% names(sections)) {
    mplus.inp$model.constraint <- lav_mplus_syntax_constraints(sections$model.constraint)
    mplus.inp$model <- paste(mplus.inp$model, mplus.inp$model.constraint, sep = "\n")
  }

  # read mplus data (and handle missing spec)
  mplus.inp$data <- lav_mplus_path_data(mplus.inp, inpfile)

  # handle bootstrapping specification
  se <- "default"
  bootstrap <- 1000L
  test <- "default"
  if (!is.null(mplus.inp$analysis$bootstrap)) {
    boot.type <- "standard"
    # check whether standard versus residual bootstrap is specified
    if ((boot.match <- regexpr("\\((\\w+)\\)", mplus.inp$analysis$bootstrap, perl = TRUE)) > 0L) {
      boot.type <- tolower(substr(mplus.inp$analysis$bootstrap, attr(boot.match, "capture.start"), attr(boot.match, "capture.start") + attr(boot.match, "capture.length") - 1L))
    }

    if (boot.type == "residual") test <- "Bollen.Stine"

    se <- "bootstrap"

    if ((nboot.match <- regexpr("^\\s*(\\d+)", mplus.inp$analysis$bootstrap, perl = TRUE)) > 0L) {
      bootstrap <- as.numeric(substr(mplus.inp$analysis$bootstrap, attr(nboot.match, "capture.start"), attr(nboot.match, "capture.start") + attr(nboot.match, "capture.length") - 1L))
    }
  }

  if (run) {
    fit <- sem(mplus.inp$model, data = mplus.inp$data, meanstructure = meanstructure, mimic = "Mplus", estimator = estimator, test = test, se = se, bootstrap = bootstrap, information = information)
    fit@external <- list(mplus.inp = mplus.inp)
  } else {
    fit <- mplus.inp # just return the syntax outside of a lavaan object
  }

  return(fit)
}


lav_mplus_text_fields <- function(section.text, required) {
  if (is.null(section.text)) {
    return(NULL)
  }

  # The parser breaks down when there is a line with a trailing comment because then splitting on semicolon will combine it with the following line
  # Thus, trim off trailing comments before initial split
  section.text <- gsub("\\s*!.*$", "", section.text, perl = TRUE)
  section.split <- strsplit(paste(section.text, collapse = " "), ";", fixed = TRUE)[[1]] # split on semicolons
  section.divide <- list()

  for (cmd in section.split) {
    if (grepl("^\\s*!.*", cmd, perl = TRUE)) next # skip comment lines
    if (grepl("^\\s+$", cmd, perl = TRUE)) next # skip blank lines

    # mplus is apparently tolerant of specifications that don't include IS/ARE/=
    # example: usevariables x1-x10;
    # thus, split on spaces and assume that first element is lhs, drop second element if IS/ARE/=, and assume remainder is rhs

    # but if user uses equals sign, then spaces will not always be present (e.g., usevariables=x1-x10)
    if ((leadingEquals <- regexpr("^\\s*[A-Za-z]+[A-Za-z_-]*\\s*(=)", cmd[1L], perl = TRUE))[1L] > 0) {
      cmdName <- lav_mplus_trim(substr(cmd[1L], 1, attr(leadingEquals, "capture.start") - 1))
      cmdArgs <- lav_mplus_trim(substr(cmd[1L], attr(leadingEquals, "capture.start") + 1, nchar(cmd[1L])))
    } else {
      cmd.spacesplit <- strsplit(lav_mplus_trim(cmd[1L]), "\\s+", perl = TRUE)[[1L]]

      if (length(cmd.spacesplit) < 2L) {
        # for future: make room for this function to prase things like just TECH13 (no rhs)
      } else {
        cmdName <- lav_mplus_trim(cmd.spacesplit[1L])
        if (length(cmd.spacesplit) > 2L && tolower(cmd.spacesplit[2L]) %in% c("is", "are")) {
          cmdArgs <- paste(cmd.spacesplit[3L:length(cmd.spacesplit)], collapse = " ") # remainder, removing is/are
        } else {
          cmdArgs <- paste(cmd.spacesplit[2L:length(cmd.spacesplit)], collapse = " ") # is/are not used, so just join rhs
        }
      }
    }

    section.divide[[make.names(tolower(cmdName))]] <- cmdArgs
  }

  if (!missing(required)) {
    stopifnot(all(required %in% names(section.divide)))
  }
  return(section.divide)
}

# helper function
lav_mplus_path_splitted <- function(abspath) {
  # function to split path into path and filename
  # code adapted from R.utils filePath command
  if (!is.character(abspath)) lav_msg_stop(gettext(
    "Path not a character string"))
  if (nchar(abspath) < 1 || is.na(abspath)) lav_msg_stop(gettext(
    "Path is missing or of zero length"))

  components <- strsplit(abspath, split = "[\\/]")[[1]]
  lcom <- length(components)

  stopifnot(lcom > 0)

  # the file is the last element in the list. In the case of length == 1, this will extract the only element.
  relFilename <- components[lcom]
  absolute <- FALSE

  if (lcom == 1) {
    dirpart <- NA_character_
  } else if (lcom > 1) {
    # drop the file from the list (the last element)
    components <- components[-lcom]
    dirpart <- do.call("file.path", as.list(components))

    # if path begins with C:, /, //, or \\, then treat as absolute
    if (grepl("^([A-Z]{1}:|/|//|\\\\)+.*$", dirpart, perl = TRUE)) absolute <- TRUE
  }

  return(list(directory = dirpart, filename = relFilename, absolute = absolute))
}

lav_mplus_path_data <- function(mplus.inp, inpfile) {
  # handle issue of lav_mplus_lavaan being called with an absolute path, whereas mplus has only a local data file
  inpfile.split <- lav_mplus_path_splitted(inpfile)
  datfile.split <- lav_mplus_path_splitted(mplus.inp$data$file)

  # if inp file target directory is non-empty, but mplus data is without directory, then append
  # inp file directory to mplus data. This ensures that R need not be in the working directory
  # to read the dat file. But if mplus data has an absolute directory, don't append

  # if mplus data directory is present and absolute, or if no directory in input file, just use filename as is
  if (!is.na(datfile.split$directory) && datfile.split$absolute) {
    datFile <- mplus.inp$data$file
  } # just use mplus data filename if it has absolute path
  else if (is.na(inpfile.split$directory)) {
    datFile <- mplus.inp$data$file
  } # just use mplus data filename if inp file is missing path (working dir)
  else {
    datFile <- file.path(inpfile.split$directory, mplus.inp$data$file)
  } # dat file path is relative or absent, and inp file directory is present

  if (!file.exists(datFile)) {
    lav_msg_warn(gettext("Cannot find data file:"), datFile)
    return(NULL)
  }

  # handle missing is/are:
  missList <- NULL
  if (!is.null(missSpec <- mplus.inp$variable$missing)) {
    expandMissVec <- function(missStr) {
      # sub-function to obtain a vector of all missing values within a set of parentheses
      missSplit <- strsplit(missStr, "\\s+")[[1L]]
      missVals <- c()
      for (f in missSplit) {
        if ((hyphenPos <- regexpr("\\d+(-)\\d+", f, perl = TRUE))[1L] > -1L) {
          # expand hyphen
          preHyphen <- substr(f, 1, attr(hyphenPos, "capture.start") - 1)
          postHyphen <- substr(f, attr(hyphenPos, "capture.start") + 1, nchar(f))
          missVals <- c(missVals, as.character(seq(preHyphen, postHyphen)))
        } else {
          # append to vector
          missVals <- c(missVals, f)
        }
      }
      return(as.numeric(missVals))
    }

    if (missSpec == "." || missSpec == "*") { # case 1: MISSING ARE|=|IS .;
      na.strings <- missSpec
    } else if ((allMatch <- regexpr("\\s*ALL\\s*\\(([^\\)]+)\\)", missSpec, perl = TRUE))[1L] > -1L) { # case 2: use of ALL with parens
      missStr <- lav_mplus_trim(substr(missSpec, attr(allMatch, "capture.start"), attr(allMatch, "capture.start") + attr(allMatch, "capture.length") - 1L))
      na.strings <- expandMissVec(missStr)
    } else { # case 3: specific missing values per variable
      # process each element
      missBlocks <- gregexpr("(?:(\\w+)\\s+\\(([^\\)]+)\\))+", missSpec, perl = TRUE)[[1]]
      missList <- list()

      if (missBlocks[1L] > -1L) {
        for (i in 1:length(missBlocks)) {
          vname <- substr(missSpec, attr(missBlocks, "capture.start")[i, 1L], attr(missBlocks, "capture.start")[i, 1L] + attr(missBlocks, "capture.length")[i, 1L] - 1L)
          vmiss <- substr(missSpec, attr(missBlocks, "capture.start")[i, 2L], attr(missBlocks, "capture.start")[i, 2L] + attr(missBlocks, "capture.length")[i, 2L] - 1L)

          vnameHyphen <- regexpr("(\\w+)-(\\w+)", vname, perl = TRUE)[1L]
          if (vnameHyphen > -1L) {
            # lookup against variable names
            vstart <- which(mplus.inp$variable$names == substr(vname, attr(vnameHyphen, "capture.start")[1L], attr(vnameHyphen, "capture.start")[1L] + attr(vnameHyphen, "capture.length")[1L] - 1L))
            vend <- which(mplus.inp$variable$names == substr(vname, attr(vnameHyphen, "capture.start")[2L], attr(vnameHyphen, "capture.start")[2L] + attr(vnameHyphen, "capture.length")[2L] - 1L))
            if (length(vstart) == 0L || length(vend) == 0L) {
              lav_msg_stop(gettext("Unable to lookup missing variable list: "),
                           vname)
            }
            # I suppose start or finish could be mixed up
            if (vstart > vend) {
              vstart.orig <- vstart
              vstart <- vend
              vend <- vstart.orig
            }
            vname <- mplus.inp$variable$names[vstart:vend]
          }

          missVals <- expandMissVec(vmiss)

          for (j in 1:length(vname)) {
            missList[[vname[j]]] <- missVals
          }
        }
      } else {
        lav_msg_stop(gettext("I don't understand this missing specification:"),
                     missSpec)
      }
    }
  } else {
    na.strings <- "NA"
  }

  if (!is.null(missList)) {
    dat <- read.table(datFile, header = FALSE, col.names = mplus.inp$variable$names, colClasses = "numeric")
    # loop over variables in missList and set missing values to NA
    dat[, names(missList)] <- lapply(names(missList), function(vmiss) {
      dat[which(dat[, vmiss] %in% missList[[vmiss]]), vmiss] <- NA
      return(dat[, vmiss])
    })

    names(dat) <- mplus.inp$variable$names # loses these from the lapply
  } else {
    dat <- read.table(datFile, header = FALSE, col.names = mplus.inp$variable$names, na.strings = na.strings, colClasses = "numeric")
  }


  # TODO: support covariance/mean+cov inputs

  # store categorical variables as ordered factors
  if (!is.null(mplus.inp$variable$categorical)) {
    dat[, c(mplus.inp$variable$categorical)] <- lapply(dat[, c(mplus.inp$variable$categorical), drop = FALSE], ordered)
  }

  return(dat)
}


lav_mplus_text_sections <- function(inpfile.text, filename) {
  inputHeaders <- grep("^\\s*(title:|data.*:|variable:|define:|analysis:|model.*:|output:|savedata:|plot:|montecarlo:)", inpfile.text, ignore.case = TRUE, perl = TRUE)

  stopifnot(length(inputHeaders) > 0L)

  mplus.sections <- list()

  for (h in 1:length(inputHeaders)) {
    sectionEnd <- ifelse(h < length(inputHeaders), inputHeaders[h + 1] - 1, length(inpfile.text))
    section <- inpfile.text[inputHeaders[h]:sectionEnd]
    sectionName <- lav_mplus_trim(sub("^([^:]+):.*$", "\\1", section[1L], perl = TRUE)) # obtain text before the colon

    # dump section name from input syntax
    section[1L] <- sub("^[^:]+:(.*)$", "\\1", section[1L], perl = TRUE)

    mplus.sections[[make.names(tolower(sectionName))]] <- section
  }

  return(mplus.sections)
}

# the multivariate normal distribution + missing values
#  (so-called 'FIML')

# 1) loglikelihood (from raw data, or sample statitics)
# 2) derivatives with respect to mu, Sigma, vech(Sigma)
# 3) casewise scores with respect to mu, vech(Sigma), mu + vech(Sigma)
# 4) hessian of mu + vech(Sigma)
# 5) (unit) information of mu + vech(Sigma)
#    5a: (unit)    expected information
#    5b: (unit)    observed information
#    5c: (unit) first.order information
#    5d: lav_mvnorm_missing_information_both (both observed + first.order)

# 6) inverted information h0 mu + vech(Sigma)
#    6a: /
#    6b: /
#    6c: /
# 7) ACOV h0 mu + vech(Sigma)
#    7a: 1/N * inverted expected    information
#    7b: 1/N * inverted observed    information
#    7c: 1/N * inverted first-order information
#    7d: sandwich acov

# 10) additional functions
#      - lav_mvnorm_missing_impute_pattern
#      - lav_mvnorm_missing_estep


# YR 09 Feb 2016: first version
# YR 19 Mar 2017: 10)
# YR 03 Okt 2018: a few functions gain a wt= argument
# YR 01 Jul 2018: first_order functions gain cluster.idx= argument


# 1) likelihood

# 1a: input is raw data
#  - two strategies: 1) using missing patterns (pattern = TRUE)
#                    2) truly case per case    (pattern = FALSE)
#    depending on the sample size, missing patterns, etc... one can be
#    (much) faster than the other
lav_mvnorm_missing_loglik_data <- function(Y = NULL,
                                           Mu = NULL,
                                           wt = NULL,
                                           Sigma = NULL,
                                           x.idx = integer(0L),
                                           casewise = FALSE,
                                           pattern = TRUE,
                                           Sinv.method = "eigen",
                                           log2pi = TRUE,
                                           minus.two = FALSE) {
  if (pattern) {
    llik <- lav_mvnorm_missing_llik_pattern(
      Y = Y, wt = wt, Mu = Mu,
      Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method,
      log2pi = log2pi, minus.two = minus.two
    )
  } else {
    llik <- lav_mvnorm_missing_llik_casewise(
      Y = Y, wt = wt, Mu = Mu,
      Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method,
      log2pi = log2pi, minus.two = minus.two
    )
  }

  if (casewise) {
    loglik <- llik
  } else {
    loglik <- sum(llik, na.rm = TRUE)
  }

  loglik
}

# 1b: input are sample statistics (mean, cov, N) per pattern
lav_mvnorm_missing_loglik_samplestats <- function(Yp = NULL,
                                                  Mu = NULL,
                                                  Sigma = NULL,
                                                  x.idx = integer(0L),
                                                  x.mean = NULL,
                                                  x.cov = NULL,
                                                  Sinv.method = "eigen",
                                                  log2pi = TRUE,
                                                  minus.two = FALSE) {
  LOG.2PI <- log(2 * pi)
  pat.N <- length(Yp)
  P <- length(Yp[[1]]$var.idx)

  # global inverse + logdet
  Sigma.inv <- lav_matrix_symmetric_inverse(
    S = Sigma, logdet = TRUE,
    Sinv.method = Sinv.method
  )
  Sigma.logdet <- attr(Sigma.inv, "logdet")

  # DIST/logdet per pattern
  DIST <- logdet <- P.LOG.2PI <- numeric(pat.N)

  # for each pattern, compute sigma.inv/logdet; compute DIST for all
  # observations of this pattern
  for (p in seq_len(pat.N)) {
    # observed variables for this pattern
    var.idx <- Yp[[p]]$var.idx

    # missing values for this pattern
    na.idx <- which(!var.idx)

    # constant
    P.LOG.2PI[p] <- sum(var.idx) * LOG.2PI * Yp[[p]]$freq

    # invert Sigma for this pattern
    if (length(na.idx) > 0L) {
      sigma.inv <- lav_matrix_symmetric_inverse_update(
        S.inv = Sigma.inv,
        rm.idx = na.idx, logdet = TRUE, S.logdet = Sigma.logdet
      )
      logdet[p] <- attr(sigma.inv, "logdet") * Yp[[p]]$freq
    } else {
      sigma.inv <- Sigma.inv
      logdet[p] <- Sigma.logdet * Yp[[p]]$freq
    }

    TT <- Yp[[p]]$SY + tcrossprod(Yp[[p]]$MY - Mu[var.idx])
    DIST[p] <- sum(sigma.inv * TT) * Yp[[p]]$freq
  }

  # loglikelihood all data
  if (log2pi) {
    loglik <- sum(-(P.LOG.2PI + logdet + DIST) / 2)
  } else {
    loglik <- sum(-(logdet + DIST) / 2)
  }

  if (minus.two) {
    loglik <- -2 * loglik
  }

  # x.idx
  if (length(x.idx) > 0L) {
    stopifnot(!is.null(x.cov))
    # Note: x.cov should be identical to Sigma[x.idx, x.idx]
    #       so we don't really need x.cov
    N <- sum(sapply(Yp, "[[", "freq"))
    loglik.x <- lav_mvnorm_h1_loglik_samplestats(
      sample.cov = x.cov,
      sample.nobs = N
    )

    loglik <- loglik - loglik.x
  }

  loglik
}

## casewise loglikelihoods

# casewise Sinv.method
lav_mvnorm_missing_llik_casewise <- function(Y = NULL,
                                             wt = NULL,
                                             Mu = NULL,
                                             Sigma = NULL,
                                             x.idx = integer(0L),
                                             Sinv.method = "eigen",
                                             log2pi = TRUE,
                                             minus.two = FALSE) {
  P <- NCOL(Y)
  LOG.2PI <- log(2 * pi)
  Mu <- as.numeric(Mu)
  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }
  NY <- NROW(Y)

  # global inverse + logdet
  Sigma.inv <- lav_matrix_symmetric_inverse(
    S = Sigma, logdet = TRUE,
    Sinv.method = Sinv.method
  )
  Sigma.logdet <- attr(Sigma.inv, "logdet")

  # subtract Mu
  Yc <- t(t(Y) - Mu)

  # DIST/logdet per case
  DIST <- logdet <- P.LOG.2PI <- rep(as.numeric(NA), NY)

  # missing pattern per case
  OBS <- !is.na(Y)
  P.i <- rowSums(OBS)

  # constant
  P.LOG.2PI <- P.i * LOG.2PI

  # complete cases first (only an advantage if we have mostly complete
  # observations)
  other.idx <- seq_len(NY)
  complete.idx <- which(P.i == P)
  if (length(complete.idx) > 0L) {
    other.idx <- other.idx[-complete.idx]
    DIST[complete.idx] <-
      rowSums(Yc[complete.idx, , drop = FALSE] %*% Sigma.inv *
        Yc[complete.idx, , drop = FALSE])
    logdet[complete.idx] <- Sigma.logdet
  }

  # non-complete cases
  for (i in other.idx) {
    na.idx <- which(!OBS[i, ])

    # catch empty cases
    if (length(na.idx) == P) next

    # invert Sigma for this pattern
    sigma.inv <- lav_matrix_symmetric_inverse_update(
      S.inv = Sigma.inv,
      rm.idx = na.idx, logdet = TRUE, S.logdet = Sigma.logdet
    )
    logdet[i] <- attr(sigma.inv, "logdet")

    # distance for this case
    DIST[i] <- sum(sigma.inv * crossprod(Yc[i, OBS[i, ], drop = FALSE]))
  }

  # compute casewise loglikelihoods
  if (log2pi) {
    llik <- -(P.LOG.2PI + logdet + DIST) / 2
  } else {
    llik <- -(logdet + DIST) / 2
  }

  # minus.two
  if (minus.two) {
    llik <- -2 * llik
  }

  # weights?
  if (!is.null(wt)) {
    llik <- llik * wt
  }

  # x.idx
  if (length(x.idx) > 0L) {
    llik.x <- lav_mvnorm_missing_llik_casewise(
      Y = Y[, x.idx, drop = FALSE],
      wt = wt, Mu = Mu[x.idx],
      Sigma = Sigma[x.idx, x.idx, drop = FALSE],
      x.idx = integer(0L), Sinv.method = Sinv.method,
      log2pi = log2pi, minus.two = minus.two
    )
    llik <- llik - llik.x
  }

  llik
}

# pattern-based, but casewise loglikelihoods
lav_mvnorm_missing_llik_pattern <- function(Y = NULL,
                                            Mp = NULL,
                                            wt = NULL,
                                            Mu = NULL,
                                            Sigma = NULL,
                                            x.idx = integer(0L),
                                            Sinv.method = "eigen",
                                            log2pi = TRUE,
                                            minus.two = FALSE) {
  P <- NCOL(Y)
  LOG.2PI <- log(2 * pi)
  Mu <- as.numeric(Mu)
  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }
  NY <- NROW(Y)

  # global inverse + logdet
  Sigma.inv <- lav_matrix_symmetric_inverse(
    S = Sigma, logdet = TRUE,
    Sinv.method = Sinv.method
  )
  Sigma.logdet <- attr(Sigma.inv, "logdet")

  # subtract Mu
  Yc <- t(t(Y) - Mu)

  # DIST/logdet per case
  DIST <- logdet <- P.LOG.2PI <- rep(as.numeric(NA), NY)

  # missing patterns
  if (is.null(Mp)) {
    Mp <- lav_data_missing_patterns(Y)
  }

  # for each pattern, compute sigma.inv/logdet; compute DIST for all
  # observations of this pattern
  for (p in seq_len(Mp$npatterns)) {
    # observed values for this pattern
    var.idx <- Mp$pat[p, ]

    # missing values for this pattern
    na.idx <- which(!var.idx)

    # identify cases with this pattern
    case.idx <- Mp$case.idx[[p]]

    # constant
    P.LOG.2PI[case.idx] <- sum(var.idx) * LOG.2PI

    # invert Sigma for this pattern
    if (length(na.idx) > 0L) {
      sigma.inv <- lav_matrix_symmetric_inverse_update(
        S.inv = Sigma.inv,
        rm.idx = na.idx, logdet = TRUE, S.logdet = Sigma.logdet
      )
      logdet[case.idx] <- attr(sigma.inv, "logdet")
    } else {
      sigma.inv <- Sigma.inv
      logdet[case.idx] <- Sigma.logdet
    }

    if (Mp$freq[p] == 1L) {
      DIST[case.idx] <- sum(sigma.inv *
        crossprod(Yc[case.idx, var.idx, drop = FALSE]))
    } else {
      DIST[case.idx] <-
        rowSums(Yc[case.idx, var.idx, drop = FALSE] %*% sigma.inv *
          Yc[case.idx, var.idx, drop = FALSE])
    }
  }

  # compute casewise loglikelihoods
  if (log2pi) {
    llik <- -(P.LOG.2PI + logdet + DIST) / 2
  } else {
    llik <- -(logdet + DIST) / 2
  }

  # minus.two
  if (minus.two) {
    llik <- -2 * llik
  }

  # weights?
  if (!is.null(wt)) {
    llik <- llik * wt
  }

  # x.idx -- using casewise (as patterns for Y may not be the same as
  #                          patterns for Y[,-x.idx])
  if (length(x.idx) > 0L) {
    llik.x <- lav_mvnorm_missing_llik_casewise(
      Y = Y[, x.idx, drop = FALSE],
      wt = wt, Mu = Mu[x.idx],
      Sigma = Sigma[x.idx, x.idx, drop = FALSE],
      x.idx = integer(0L), Sinv.method = Sinv.method,
      log2pi = log2pi, minus.two = minus.two
    )
    llik <- llik - llik.x
  }

  llik
}




# 2. Derivatives

# 2a: derivative logl with respect to mu
lav_mvnorm_missing_dlogl_dmu <- function(Y = NULL,
                                         wt = NULL,
                                         Mu = NULL,
                                         Sigma = NULL,
                                         x.idx = integer(0L),
                                         Sigma.inv = NULL,
                                         Sinv.method = "eigen") {
  SC <- lav_mvnorm_missing_scores_mu(
    Y = Y, wt = wt, Mu = Mu, Sigma = Sigma,
    x.idx = x.idx, Sigma.inv = Sigma.inv, Sinv.method = Sinv.method
  )

  colSums(SC, na.rm = TRUE)
}

# 2abis: using samplestats
lav_mvnorm_missing_dlogl_dmu_samplestats <- function(Yp = NULL,
                                                     Mu = NULL,
                                                     Sigma = NULL,
                                                     x.idx = integer(0L),
                                                     Sigma.inv = NULL,
                                                     Sinv.method = "eigen") {
  pat.N <- length(Yp)
  P <- length(Yp[[1]]$var.idx)

  if (is.null(Sigma.inv)) {
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # dmu
  dmu <- numeric(P)

  # for each pattern, compute sigma.inv
  for (p in seq_len(pat.N)) {
    # observed variables for this pattern
    var.idx <- Yp[[p]]$var.idx

    # missing values for this pattern
    na.idx <- which(!var.idx)

    # invert Sigma for this pattern
    if (length(na.idx) > 0L) {
      sigma.inv <- lav_matrix_symmetric_inverse_update(
        S.inv = Sigma.inv,
        rm.idx = na.idx, logdet = FALSE
      )
    } else {
      sigma.inv <- Sigma.inv
    }

    # dmu for this pattern
    dmu.pattern <- as.numeric(sigma.inv %*% (Yp[[p]]$MY - Mu[var.idx]))

    # update mu
    dmu[var.idx] <- dmu[var.idx] + (dmu.pattern * Yp[[p]]$freq)
  }

  # fixed.x?
  if (length(x.idx) > 0L) {
    dmu[x.idx] <- 0
  }

  dmu
}



# 2b: derivative logl with respect to Sigma (full matrix, ignoring symmetry)
lav_mvnorm_missing_dlogl_dSigma <- function(Y = NULL,
                                            Mp = NULL,
                                            wt = NULL,
                                            Mu = NULL,
                                            Sigma = NULL,
                                            x.idx = integer(0L),
                                            Sigma.inv = NULL,
                                            Sinv.method = "eigen") {
  P <- NCOL(Y)
  Mu <- as.numeric(Mu)
  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }
  NY <- NROW(Y)

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # subtract Mu
  Yc <- t(t(Y) - Mu)

  # dvechSigma
  dSigma <- matrix(0, P, P)

  # missing patterns
  if (is.null(Mp)) {
    Mp <- lav_data_missing_patterns(Y)
  }

  # for each pattern
  for (p in seq_len(Mp$npatterns)) {
    # observed values for this pattern
    var.idx <- Mp$pat[p, ]

    # missing values for this pattern
    na.idx <- which(!var.idx)

    # cases with this pattern
    case.idx <- Mp$case.idx[[p]]

    # invert Sigma for this pattern
    if (length(na.idx) > 0L) {
      sigma.inv <- lav_matrix_symmetric_inverse_update(
        S.inv = Sigma.inv,
        rm.idx = na.idx, logdet = FALSE
      )
    } else {
      sigma.inv <- Sigma.inv
    }

    if (!is.null(wt)) {
      FREQ <- sum(wt[case.idx])
    } else {
      FREQ <- Mp$freq[p]
    }

    if (length(case.idx) > 1L) {
      if (!is.null(wt)) {
        out <- stats::cov.wt(Y[case.idx, var.idx, drop = FALSE],
          wt = wt[Mp$case.idx[[p]]], method = "ML"
        )
        SY <- out$cov
        MY <- out$center
        W.tilde <- SY + tcrossprod(MY - Mu[var.idx])
      } else {
        W.tilde <- crossprod(Yc[case.idx, var.idx, drop = FALSE]) / FREQ
      }
    } else {
      W.tilde <- tcrossprod(Yc[case.idx, var.idx])
    }

    # dSigma for this pattern
    dSigma.pattern <- matrix(0, P, P)
    dSigma.pattern[var.idx, var.idx] <- -(1 / 2) * (sigma.inv -
      (sigma.inv %*% W.tilde %*% sigma.inv))

    # update dSigma
    dSigma <- dSigma + (dSigma.pattern * FREQ)
  }

  # fixed.x?
  if (length(x.idx) > 0L) {
    dSigma[x.idx, x.idx] <- 0
  }

  dSigma
}

# 2bbis: using samplestats
lav_mvnorm_missing_dlogl_dSigma_samplestats <- function(Yp = NULL,
                                                        Mu = NULL,
                                                        Sigma = NULL,
                                                        x.idx = integer(0L),
                                                        Sigma.inv = NULL,
                                                        Sinv.method = "eigen") {
  pat.N <- length(Yp)
  P <- length(Yp[[1]]$var.idx)

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # dvechSigma
  dSigma <- matrix(0, P, P)

  # for each pattern
  for (p in seq_len(pat.N)) {
    # observed variables for this pattern
    var.idx <- Yp[[p]]$var.idx

    # missing values for this pattern
    na.idx <- which(!var.idx)

    # invert Sigma for this pattern
    if (length(na.idx) > 0L) {
      sigma.inv <- lav_matrix_symmetric_inverse_update(
        S.inv = Sigma.inv,
        rm.idx = na.idx, logdet = FALSE
      )
    } else {
      sigma.inv <- Sigma.inv
    }

    W.tilde <- Yp[[p]]$SY + tcrossprod(Yp[[p]]$MY - Mu[var.idx])

    # dSigma for this pattern
    dSigma.pattern <- matrix(0, P, P)
    dSigma.pattern[var.idx, var.idx] <- -(1 / 2) * (sigma.inv -
      (sigma.inv %*% W.tilde %*% sigma.inv))

    # update dSigma
    dSigma <- dSigma + (dSigma.pattern * Yp[[p]]$freq)
  }

  # fixed.x?
  if (length(x.idx) > 0L) {
    dSigma[x.idx, x.idx] <- 0
  }

  dSigma
}


# 2c: derivative logl with respect to vech(Sigma)
lav_mvnorm_missing_dlogl_dvechSigma <- function(Y = NULL,
                                                wt = NULL,
                                                Mu = NULL,
                                                x.idx = integer(0L),
                                                Sigma = NULL,
                                                Sigma.inv = NULL,
                                                Sinv.method = "eigen") {
  dSigma <- lav_mvnorm_missing_dlogl_dSigma(
    Y = Y, wt = wt, Mu = Mu,
    Sigma = Sigma, x.idx = x.idx, Sigma.inv = Sigma.inv,
    Sinv.method = Sinv.method
  )

  dvechSigma <- as.numeric(lav_matrix_duplication_pre(
    as.matrix(lav_matrix_vec(dSigma))
  ))

  dvechSigma
}

# 2cbis: using samplestats
lav_mvnorm_missing_dlogl_dvechSigma_samplestats <-
  function(Yp = NULL,
           Mu = NULL,
           Sigma = NULL,
           x.idx = integer(0L),
           Sigma.inv = NULL,
           Sinv.method = "eigen") {
    pat.N <- length(Yp)
    P <- length(Yp[[1]]$var.idx)

    if (is.null(Sigma.inv)) {
      # invert Sigma
      Sigma.inv <- lav_matrix_symmetric_inverse(
        S = Sigma, logdet = FALSE,
        Sinv.method = Sinv.method
      )
    }

    # dvechSigma
    dvechSigma <- numeric(P * (P + 1) / 2)

    # for each pattern
    for (p in seq_len(pat.N)) {
      # observed variables for this pattern
      var.idx <- Yp[[p]]$var.idx

      # missing values for this pattern
      na.idx <- which(!var.idx)

      # invert Sigma for this pattern
      if (length(na.idx) > 0L) {
        sigma.inv <- lav_matrix_symmetric_inverse_update(
          S.inv = Sigma.inv,
          rm.idx = na.idx, logdet = FALSE
        )
      } else {
        sigma.inv <- Sigma.inv
      }

      W.tilde <- Yp[[p]]$SY + tcrossprod(Yp[[p]]$MY - Mu[var.idx])

      # dSigma for this pattern
      dSigma.pattern <- matrix(0, P, P)
      dSigma.pattern[var.idx, var.idx] <- -(1 / 2) * (sigma.inv -
        (sigma.inv %*% W.tilde %*% sigma.inv))

      # fixed.x?
      if (length(x.idx) > 0L) {
        dSigma.pattern[x.idx, x.idx] <- 0
      }

      # convert to vechSigma
      dvechSigma.pattern <- as.numeric(lav_matrix_duplication_pre(
        as.matrix(lav_matrix_vec(dSigma.pattern))
      ))

      # update dvechSigma
      dvechSigma <- dvechSigma + (dvechSigma.pattern * Yp[[p]]$freq)
    }

    dvechSigma
  }




# 3. Casewise scores

# 3a: casewise scores with respect to mu
lav_mvnorm_missing_scores_mu <- function(Y = NULL,
                                         wt = NULL,
                                         Mp = NULL,
                                         Mu = NULL,
                                         Sigma = NULL,
                                         x.idx = integer(0L),
                                         Sigma.inv = NULL,
                                         Sinv.method = "eigen") {
  P <- NCOL(Y)
  Mu <- as.numeric(Mu)
  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }
  NY <- NROW(Y)

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # missing patterns
  if (is.null(Mp)) {
    Mp <- lav_data_missing_patterns(Y)
  }

  # subtract Mu
  Yc <- t(t(Y) - Mu)

  # dmu per case
  dmu <- matrix(as.numeric(NA), NY, P)

  # for each pattern, compute sigma.inv
  for (p in seq_len(Mp$npatterns)) {
    # observed values for this pattern
    var.idx <- Mp$pat[p, ]

    # missing values for this pattern
    na.idx <- which(!var.idx)

    case.idx <- Mp$case.idx[[p]]

    # invert Sigma for this pattern
    if (length(na.idx) > 0L) {
      sigma.inv <- lav_matrix_symmetric_inverse_update(
        S.inv = Sigma.inv,
        rm.idx = na.idx, logdet = FALSE
      )
    } else {
      sigma.inv <- Sigma.inv
    }

    # compute dMu for all observations of this pattern
    dmu[case.idx, var.idx] <-
      Yc[case.idx, var.idx, drop = FALSE] %*% sigma.inv
  }

  # weights
  if (!is.null(wt)) {
    dmu <- dmu * wt
  }

  # fixed.x?
  if (length(x.idx) > 0L) {
    dmu[, x.idx] <- 0
  }

  dmu
}

# 3b: casewise scores with respect to vech(Sigma)
lav_mvnorm_missing_scores_vech_sigma <- function(Y = NULL,
                                                 wt = NULL,
                                                 Mp = NULL,
                                                 Mu = NULL,
                                                 Sigma = NULL,
                                                 x.idx = integer(0L),
                                                 Sigma.inv = NULL,
                                                 Sinv.method = "eigen") {
  P <- NCOL(Y)
  Mu <- as.numeric(Mu)
  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }
  NY <- NROW(Y)

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # for the tcrossprod
  idx1 <- lav_matrix_vech_col_idx(P)
  idx2 <- lav_matrix_vech_row_idx(P)

  # vech(Sigma.inv)
  iSigma <- lav_matrix_vech(Sigma.inv)

  # missing patterns
  if (is.null(Mp)) {
    Mp <- lav_data_missing_patterns(Y)
  }

  # subtract Mu
  Yc <- t(t(Y) - Mu)

  # SC
  SC <- matrix(as.numeric(NA), nrow = NY, ncol = length(iSigma))

  # for each pattern
  for (p in seq_len(Mp$npatterns)) {
    # observed values for this pattern
    var.idx <- Mp$pat[p, ]

    # missing values for this pattern
    na.idx <- which(!var.idx)

    # cases with this pattern
    case.idx <- Mp$case.idx[[p]]

    # invert Sigma for this pattern
    if (length(na.idx) > 0L) {
      sigma.inv <- lav_matrix_symmetric_inverse_update(
        S.inv = Sigma.inv,
        rm.idx = na.idx, logdet = FALSE
      )
      tmp <- matrix(0, P, P)
      tmp[var.idx, var.idx] <- sigma.inv
      isigma <- lav_matrix_vech(tmp)
    } else {
      sigma.inv <- Sigma.inv
      isigma <- iSigma
    }

    # postmultiply these cases with sigma.inv
    Yc[case.idx, var.idx] <- Yc[case.idx, var.idx] %*% sigma.inv

    # tcrossprod
    SC[case.idx, ] <- Yc[case.idx, idx1] * Yc[case.idx, idx2]

    # substract isigma from each row
    SC[case.idx, ] <- t(t(SC[case.idx, , drop = FALSE]) - isigma)
  }

  # adjust for vech
  SC[, lav_matrix_diagh_idx(P)] <- SC[, lav_matrix_diagh_idx(P)] / 2

  # weights
  if (!is.null(wt)) {
    SC <- SC * wt
  }

  # fixed.x?
  if (length(x.idx) > 0L) {
    SC[, lav_matrix_vech_which_idx(n = P, idx = x.idx)] <- 0
  }

  SC
}

# 3c: casewise scores with respect to mu + vech(Sigma)
lav_mvnorm_missing_scores_mu_vech_sigma <- function(Y = NULL,
                                                    Mp = NULL,
                                                    wt = NULL,
                                                    Mu = NULL,
                                                    Sigma = NULL,
                                                    x.idx = integer(0L),
                                                    Sigma.inv = NULL,
                                                    Sinv.method = "eigen") {
  P <- NCOL(Y)
  Mu <- as.numeric(Mu)
  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }
  NY <- NROW(Y)

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # for the tcrossprod
  idx1 <- lav_matrix_vech_col_idx(P)
  idx2 <- lav_matrix_vech_row_idx(P)

  # vech(Sigma.inv)
  iSigma <- lav_matrix_vech(Sigma.inv)

  # missing patterns
  if (is.null(Mp)) {
    Mp <- lav_data_missing_patterns(Y)
  }

  # subtract Mu
  Yc <- t(t(Y) - Mu)

  # dmu per case
  dmu <- matrix(as.numeric(NA), NY, P)

  # SC
  SC <- matrix(as.numeric(NA), nrow = NY, ncol = length(iSigma))

  # for each pattern, compute Yc %*% sigma.inv
  for (p in seq_len(Mp$npatterns)) {
    # observed values for this pattern
    var.idx <- Mp$pat[p, ]

    # missing values for this pattern
    na.idx <- which(!var.idx)

    # cases with this pattern
    case.idx <- Mp$case.idx[[p]]

    # invert Sigma for this pattern
    if (length(na.idx) > 0L) {
      sigma.inv <- lav_matrix_symmetric_inverse_update(
        S.inv = Sigma.inv,
        rm.idx = na.idx, logdet = FALSE
      )
      tmp <- matrix(0, P, P)
      tmp[var.idx, var.idx] <- sigma.inv
      isigma <- lav_matrix_vech(tmp)
    } else {
      sigma.inv <- Sigma.inv
      isigma <- iSigma
    }

    # compute dMu for all observations of this pattern
    dmu[case.idx, var.idx] <-
      Yc[case.idx, var.idx, drop = FALSE] %*% sigma.inv

    # postmultiply these cases with sigma.inv
    Yc[case.idx, var.idx] <- Yc[case.idx, var.idx] %*% sigma.inv

    # tcrossprod
    SC[case.idx, ] <- Yc[case.idx, idx1] * Yc[case.idx, idx2]

    # substract isigma from each row
    SC[case.idx, ] <- t(t(SC[case.idx, , drop = FALSE]) - isigma)
  }

  # adjust for vech
  SC[, lav_matrix_diagh_idx(P)] <- SC[, lav_matrix_diagh_idx(P)] / 2

  out <- cbind(dmu, SC)

  # weights
  if (!is.null(wt)) {
    out <- out * wt
  }

  # fixed.x?
  if (length(x.idx) > 0L) {
    not.x <- lav_matrix_vech_which_idx(n = P, idx = x.idx,
                                       #diagonal = !correlation,
                                       add.idx.at.start = TRUE)
    out[, not.x] <- 0
  }

  out
}


# 4) Hessian of logl
lav_mvnorm_missing_logl_hessian_data <- function(Y = NULL,
                                                 Mp = NULL,
                                                 wt = NULL,
                                                 Mu = NULL,
                                                 Sigma = NULL,
                                                 x.idx = integer(0L),
                                                 Sinv.method = "eigen",
                                                 Sigma.inv = NULL) {
  # missing patterns
  Yp <- lav_samplestats_missing_patterns(Y = Y, Mp = Mp, wt = wt)

  lav_mvnorm_missing_logl_hessian_samplestats(
    Yp = Yp, Mu = Mu,
    Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method,
    Sigma.inv = Sigma.inv
  )
}

lav_mvnorm_missing_logl_hessian_samplestats <-
  function(Yp = NULL,
           # wt not needed
           Mu = NULL,
           Sigma = NULL,
           x.idx = integer(0L),
           Sinv.method = "eigen",
           Sigma.inv = NULL) {
    pat.N <- length(Yp)
    P <- length(Yp[[1]]$var.idx)

    if (is.null(Sigma.inv)) {
      Sigma.inv <- lav_matrix_symmetric_inverse(
        S = Sigma, logdet = FALSE,
        Sinv.method = Sinv.method
      )
    }

    H11 <- matrix(0, P, P)
    H21 <- matrix(0, P * (P + 1) / 2, P)
    H22 <- matrix(0, P * (P + 1) / 2, P * (P + 1) / 2)

    # for each pattern, compute sigma.inv
    for (p in seq_len(pat.N)) {
      # observed variables
      var.idx <- Yp[[p]]$var.idx
      pat.freq <- Yp[[p]]$freq

      # missing values for this pattern
      na.idx <- which(!var.idx)

      # invert Sigma for this pattern
      if (length(na.idx) > 0L) {
        sigma.inv <- lav_matrix_symmetric_inverse_update(
          S.inv = Sigma.inv,
          rm.idx = na.idx, logdet = FALSE
        )
      } else {
        sigma.inv <- Sigma.inv
      }

      S.inv <- matrix(0, P, P)
      S.inv[var.idx, var.idx] <- sigma.inv

      tmp21 <- matrix(0, P, 1)
      tmp21[var.idx, 1] <- sigma.inv %*% (Yp[[p]]$MY - Mu[var.idx])

      W.tilde <- Yp[[p]]$SY + tcrossprod(Yp[[p]]$MY - Mu[var.idx])
      AAA <- (sigma.inv %*%
        (2 * W.tilde - Sigma[var.idx, var.idx, drop = FALSE]) %*%
        sigma.inv)
      tmp22 <- matrix(0, P, P)
      tmp22[var.idx, var.idx] <- AAA

      i11 <- S.inv
      i21 <- lav_matrix_duplication_pre(tmp21 %x% S.inv)
      # if (lav_use_lavaanC()) {
      #   i22 <- lavaanC::m_kronecker_dup_pre_post(S.inv, tmp22, 0.5)
      # } else {
        i22 <- (1 / 2) * lav_matrix_duplication_pre_post(S.inv %x% tmp22)
      # }
      H11 <- H11 + pat.freq * i11
      H21 <- H21 + pat.freq * i21
      H22 <- H22 + pat.freq * i22
    }

    H12 <- t(H21)

    out <- -1 * rbind(
      cbind(H11, H12),
      cbind(H21, H22)
    )

    # fixed.x?
    if (length(x.idx) > 0L) {
      not.x <- lav_matrix_vech_which_idx(n = P, idx = x.idx,
                                         #diagonal = !correlation,
                                         add.idx.at.start = TRUE)
      out[, not.x] <- 0
      out[not.x, ] <- 0
    }

    out
  }




# 5) Information

# 5a: expected unit information Mu and vech(Sigma)
#     (only useful under MCAR)
# (old term: Abeta, expected)
lav_mvnorm_missing_information_expected <- function(Y = NULL,
                                                    Mp = NULL,
                                                    wt = NULL,
                                                    Mu = NULL, # unused
                                                    Sigma = NULL,
                                                    x.idx = integer(0L),
                                                    Sigma.inv = NULL,
                                                    Sinv.method = "eigen") {
  P <- NCOL(Y)

  if (is.null(Sigma.inv)) {
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # missing patterns
  if (is.null(Mp)) {
    Mp <- lav_data_missing_patterns(Y)
  }

  # N
  if (!is.null(wt)) {
    if (length(Mp$empty.idx) > 0L) {
      N <- sum(wt) - sum(wt[Mp$empty.idx])
    } else {
      N <- sum(wt)
    }
  } else {
    N <- sum(Mp$freq) # removed empty cases!
  }

  I11 <- matrix(0, P, P)
  I22 <- matrix(0, P * (P + 1) / 2, P * (P + 1) / 2)

  # for each pattern, compute sigma.inv
  for (p in seq_len(Mp$npatterns)) {
    # observed variables
    var.idx <- Mp$pat[p, ]

    # missing values for this pattern
    na.idx <- which(!var.idx)

    # invert Sigma for this pattern
    if (length(na.idx) > 0L) {
      sigma.inv <- lav_matrix_symmetric_inverse_update(
        S.inv = Sigma.inv,
        rm.idx = na.idx, logdet = FALSE
      )
    } else {
      sigma.inv <- Sigma.inv
    }

    S.inv <- matrix(0, P, P)
    S.inv[var.idx, var.idx] <- sigma.inv

    # if (lav_use_lavaanC()) {
    #   S2.inv <- lavaanC::m_kronecker_dup_pre_post(S.inv, multiplicator = 0.5)
    # } else {
      S2.inv <- 0.5 * lav_matrix_duplication_pre_post(S.inv %x% S.inv)
    # }

    if (!is.null(wt)) {
      FREQ <- sum(wt[Mp$case.idx[[p]]])
    } else {
      FREQ <- Mp$freq[p]
    }

    I11 <- I11 + FREQ * S.inv
    I22 <- I22 + FREQ * S2.inv
  }

  out <- lav_matrix_bdiag(I11, I22) / N

  # fixed.x?
  if (length(x.idx) > 0L) {
    not.x <- lav_matrix_vech_which_idx(n = P, idx = x.idx,
                                       # diagonal = !correlation,
                                       add.idx.at.start = TRUE)
    out[not.x, ] <- 0
    out[, not.x] <- 0
  }

  out
}

# 5b: unit observed information Mu and vech(Sigma) from raw data
# (old term: Abeta, observed)
lav_mvnorm_missing_information_observed_data <- function(Y = NULL,
                                                         Mp = NULL,
                                                         wt = NULL,
                                                         Mu = NULL,
                                                         Sigma = NULL,
                                                         x.idx = integer(0L),
                                                         Sinv.method = "eigen",
                                                         Sigma.inv = NULL) {
  # missing patterns
  if (is.null(Mp)) {
    Mp <- lav_data_missing_patterns(Y)
  }

  # N
  if (!is.null(wt)) {
    if (length(Mp$empty.idx) > 0L) {
      N <- sum(wt) - sum(wt[Mp$empty.idx])
    } else {
      N <- sum(wt)
    }
  } else {
    N <- sum(Mp$freq) # removed empty cases!
  }

  # observed information
  observed <- lav_mvnorm_missing_logl_hessian_data(
    Y = Y, Mp = Mp, wt = wt,
    Mu = Mu, Sigma = Sigma, x.idx = x.idx,
    Sinv.method = Sinv.method, Sigma.inv = Sigma.inv
  )

  -observed / N
}

# 5b-bis: unit observed information Mu and vech(Sigma) from samplestats
lav_mvnorm_missing_information_observed_samplestats <-
  function(Yp = NULL,
           # wt not needed
           Mu = NULL,
           Sigma = NULL,
           x.idx = integer(0L),
           Sinv.method = "eigen",
           Sigma.inv = NULL) {
    N <- sum(sapply(Yp, "[[", "freq")) # implicitly: removed empty cases!

    # observed information
    observed <- lav_mvnorm_missing_logl_hessian_samplestats(
      Yp = Yp, Mu = Mu,
      Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method,
      Sigma.inv = Sigma.inv
    )

    -observed / N
  }

# 5c: unit first-order information Mu and vech(Sigma) from raw data
# (old term: Bbeta)
lav_mvnorm_missing_information_firstorder <- function(Y = NULL,
                                                      Mp = NULL,
                                                      wt = NULL,
                                                      cluster.idx = NULL,
                                                      Mu = NULL,
                                                      Sigma = NULL,
                                                      x.idx = integer(0L),
                                                      Sinv.method = "eigen",
                                                      Sigma.inv = NULL) {
  # missing patterns
  if (is.null(Mp)) {
    Mp <- lav_data_missing_patterns(Y)
  }

  # N
  if (!is.null(wt)) {
    if (length(Mp$empty.idx) > 0L) {
      N <- sum(wt) - sum(wt[Mp$empty.idx])
    } else {
      N <- sum(wt)
    }
  } else {
    N <- sum(Mp$freq) # removed empty cases!
  }

  SC <- lav_mvnorm_missing_scores_mu_vech_sigma(
    Y = Y, Mp = Mp, wt = wt,
    Mu = Mu, Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method,
    Sigma.inv = Sigma.inv
  )

  # handle clustering
  if (!is.null(cluster.idx)) {
    # take the sum within each cluster
    SC <- rowsum(SC, group = cluster.idx, reorder = FALSE, na.rm = TRUE)

    # lower bias is number of clusters is not very high
    nC <- nrow(SC)
    correction.factor <- nC / (nC - 1)
    SC <- SC * sqrt(correction.factor)
  }

  lav_matrix_crossprod(SC) / N
}

# 5d: both unit first-order information and expected/observed information
#     from raw data, in one go for efficiency
lav_mvnorm_missing_information_both <- function(Y = NULL,
                                                Mp = NULL,
                                                wt = NULL,
                                                cluster.idx = NULL,
                                                Mu = NULL,
                                                Sigma = NULL,
                                                x.idx = integer(0L),
                                                Sinv.method = "eigen",
                                                Sigma.inv = NULL,
                                                information = "observed") {
  P <- NCOL(Y)
  Mu <- as.numeric(Mu)

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # for the tcrossprod
  idx1 <- lav_matrix_vech_col_idx(P)
  idx2 <- lav_matrix_vech_row_idx(P)

  # vech(Sigma.inv)
  iSigma <- lav_matrix_vech(Sigma.inv)

  # missing patterns
  if (is.null(Mp)) {
    Mp <- lav_data_missing_patterns(Y)
  }

  if (information == "observed") {
    Yp <- lav_samplestats_missing_patterns(Y = Y, Mp = Mp, wt = wt)
  }

  # N
  if (!is.null(wt)) {
    if (length(Mp$empty.idx) > 0L) {
      N <- sum(wt) - sum(wt[Mp$empty.idx])
    } else {
      N <- sum(wt)
    }
  } else {
    N <- sum(Mp$freq) # removed empty cases!
  }

  # subtract Mu
  Yc <- t(t(Y) - Mu)

  # dmu per case
  dmu <- matrix(as.numeric(NA), nrow = NROW(Y), ncol = P)

  # SC
  SC <- matrix(as.numeric(NA), nrow = NROW(Y), ncol = length(iSigma))

  # expected/observed information
  I11 <- matrix(0, P, P)
  I22 <- matrix(0, P * (P + 1) / 2, P * (P + 1) / 2)
  if (information == "observed") {
    I21 <- matrix(0, P * (P + 1) / 2, P)
  }

  # for each pattern, compute Yc %*% sigma.inv
  for (p in seq_len(Mp$npatterns)) {
    # observed values for this pattern
    var.idx <- Mp$pat[p, ]

    # missing values for this pattern
    na.idx <- which(!var.idx)

    # cases with this pattern
    case.idx <- Mp$case.idx[[p]]

    # invert Sigma for this pattern
    if (length(na.idx) > 0L) {
      sigma.inv <- lav_matrix_symmetric_inverse_update(
        S.inv = Sigma.inv,
        rm.idx = na.idx, logdet = FALSE
      )
      tmp <- matrix(0, P, P)
      tmp[var.idx, var.idx] <- sigma.inv
      isigma <- lav_matrix_vech(tmp)
    } else {
      sigma.inv <- Sigma.inv
      isigma <- iSigma
    }

    # information
    S.inv <- matrix(0, P, P)
    S.inv[var.idx, var.idx] <- sigma.inv

    if (!is.null(wt)) {
      FREQ <- sum(wt[case.idx])
    } else {
      FREQ <- Mp$freq[p]
    }

    if (information == "expected") {
      # if (lav_use_lavaanC()) {
      #   S2.inv <- lavaanC::m_kronecker_dup_pre_post(S.inv, multiplicator = 0.5)
      # } else {
        S2.inv <- 0.5 * lav_matrix_duplication_pre_post(S.inv %x% S.inv)
      # }

      I11 <- I11 + FREQ * S.inv
      I22 <- I22 + FREQ * S2.inv
    } else {
      pat.freq <- Yp[[p]]$freq

      tmp21 <- matrix(0, P, 1)
      tmp21[var.idx, 1] <- sigma.inv %*% (Yp[[p]]$MY - Mu[var.idx])

      W.tilde <- Yp[[p]]$SY + tcrossprod(Yp[[p]]$MY - Mu[var.idx])
      AAA <- (sigma.inv %*%
        (2 * W.tilde - Sigma[var.idx, var.idx, drop = FALSE]) %*%
        sigma.inv)
      tmp22 <- matrix(0, P, P)
      tmp22[var.idx, var.idx] <- AAA

      i11 <- S.inv
      i21 <- lav_matrix_duplication_pre(tmp21 %x% S.inv)
      # if (lav_use_lavaanC()) {
      #   i22 <- lavaanC::m_kronecker_dup_pre_post(S.inv, tmp22, 0.5)
      # } else {
        i22 <- (1 / 2) * lav_matrix_duplication_pre_post(S.inv %x% tmp22)
      # }

      I11 <- I11 + pat.freq * i11
      I21 <- I21 + pat.freq * i21
      I22 <- I22 + pat.freq * i22
    }

    # compute dMu for all observations of this pattern
    dmu[case.idx, var.idx] <-
      Yc[case.idx, var.idx, drop = FALSE] %*% sigma.inv

    # postmultiply these cases with sigma.inv
    Yc[case.idx, var.idx] <- Yc[case.idx, var.idx] %*% sigma.inv

    # tcrossprod
    SC[case.idx, ] <- Yc[case.idx, idx1] * Yc[case.idx, idx2]

    # substract isigma from each row
    SC[case.idx, ] <- t(t(SC[case.idx, , drop = FALSE]) - isigma)
  }

  # adjust for vech
  SC[, lav_matrix_diagh_idx(P)] <- SC[, lav_matrix_diagh_idx(P)] / 2

  # add dmu
  SC <- cbind(dmu, SC)

  # weights
  if (!is.null(wt)) {
    SC <- SC * wt
  }

  # fixed.x?
  if (length(x.idx) > 0L) {
    not.x <- lav_matrix_vech_which_idx(n = P, idx = x.idx,
                                       #diagonal = !correlation,
                                       add.idx.at.start = TRUE)
    SC[, not.x] <- 0
  }

  # handle clustering
  if (!is.null(cluster.idx)) {
    # take the sum within each cluster
    SC <- rowsum(SC, group = cluster.idx, reorder = FALSE, na.rm = TRUE)

    # lower bias is number of clusters is not very high
    nC <- nrow(SC)
    correction.factor <- nC / (nC - 1)
    SC <- SC * sqrt(correction.factor)
  }

  # first order information
  Bbeta <- lav_matrix_crossprod(SC) / N

  # expected/observed information
  if (information == "expected") {
    Abeta <- lav_matrix_bdiag(I11, I22) / N
  } else {
    Abeta <- rbind(
      cbind(I11, t(I21)),
      cbind(I21, I22)
    ) / N
  }

  # fixed.x?
  if (length(x.idx) > 0L) {
    not.x <- lav_matrix_vech_which_idx(n = P, idx = x.idx,
                                       # diagonal = !correlation,
                                       add.idx.at.start = TRUE)
    Abeta[not.x, ] <- 0
    Abeta[, not.x] <- 0
  }

  list(Abeta = Abeta, Bbeta = Bbeta)
}


# 6) inverted information h0 mu + vech(Sigma)

#    6a: (unit) inverted expected information
#    NOT USED: is not equal to solve(expected)
#    (although it does converge to the same solution eventually)
# lav_mvnorm_missing_inverted_information_expected <- function(Y  = NULL,
#                                                    Mp          = NULL,
#                                                    Mu          = NULL,# unused
#                                                    Sigma       = NULL) {
#    P <- NCOL(Y)
#
#    # missing patterns
#    if(is.null(Mp)) {
#        Mp <- lav_data_missing_patterns(Y)
#    }
#
#    # N
#    N <- sum(Mp$freq) # removed empty cases!
#
#    I11 <- matrix(0, P, P)
#    I22 <- matrix(0, P*(P+1)/2, P*(P+1)/2)
#
#    # for each pattern
#    for(p in seq_len(Mp$npatterns)) {
#
#        # observed variables
#        var.idx <- Mp$pat[p,]
#
#        sigma <- matrix(0, P, P)
#        sigma[var.idx, var.idx] <- Sigma[var.idx, var.idx]
#        sigma2 <- 2 * lav_matrix_duplication_ginv_pre_post(sigma %x% sigma)
#
#        I11 <- I11 + Mp$freq[p] * sigma
#        I22 <- I22 + Mp$freq[p] * sigma2
#    }
#
#    lav_matrix_bdiag(I11, I22)/N
# }

#    6b: /

#    6c: /


# 7) ACOV h0 mu + vech(Sigma)

#    7a: 1/N * inverted expected    information

#    7b: 1/N * inverted observed    information

#    7c: 1/N * inverted first-order information

#    7d: sandwich acov



# 10) other stuff

# single imputation missing cells, under the normal model, pattern-based
# FIXME: add wt
lav_mvnorm_missing_impute_pattern <- function(Y = NULL,
                                              Mp = NULL,
                                              Mu = NULL,
                                              Sigma = NULL,
                                              Sigma.inv = NULL,
                                              Sinv.method = "eigen") {
  Mu <- as.numeric(Mu)

  # complete data
  Y.complete <- Y

  # missing patterns
  if (is.null(Mp)) {
    Mp <- lav_data_missing_patterns(Y)
  }

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # subtract Mu
  Yc <- t(t(Y) - Mu)

  # fill in data per pattern
  for (p in seq_len(Mp$npatterns)) {
    # observed values for this pattern
    var.idx <- Mp$pat[p, ]

    # if complete, nothing to do
    if (all(var.idx)) {
      next
    }

    # missing values for this pattern
    na.idx <- which(!var.idx)

    # extract observed data for these (centered) cases
    Oc <- Yc[Mp$case.idx[[p]], Mp$pat[p, ], drop = FALSE]

    # invert Sigma (Sigma_22, observed part only) for this pattern
    Sigma_22.inv <- try(
      lav_matrix_symmetric_inverse_update(
        S.inv =
          Sigma.inv, rm.idx = na.idx, logdet = FALSE
      ),
      silent = TRUE
    )
    if (inherits(Sigma_22.inv, "try-error")) {
      lav_msg_stop(gettext("Sigma_22.inv cannot be inverted"))
    }

    # estimate missing values in this pattern
    Sigma_12 <- Sigma[!var.idx, var.idx, drop = FALSE]
    Y.missing <- t(Sigma_12 %*% Sigma_22.inv %*% t(Oc) + Mu[!var.idx])

    # complete data for this pattern
    Y.complete[Mp$case.idx[[p]], !var.idx] <- Y.missing
  }

  Y.complete
}


# E-step: expectations of sum, sum of squares, sum of crossproducts
# plus correction
lav_mvnorm_missing_estep <- function(Y = NULL,
                                     Mp = NULL,
                                     wt = NULL,
                                     Mu = NULL,
                                     Sigma = NULL,
                                     Sigma.inv = NULL,
                                     Sinv.method = "eigen") {
  P <- NCOL(Y)
  Mu <- as.numeric(Mu)

  # missing patterns
  if (is.null(Mp)) {
    Mp <- lav_data_missing_patterns(Y)
  }

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # T1, T2
  T1 <- numeric(P)
  T2 <- matrix(0, P, P)

  # update T1 and T2 per pattern
  for (p in seq_len(Mp$npatterns)) {
    # observed values for this pattern
    var.idx <- Mp$pat[p, ]

    # extract observed data
    O <- Y[Mp$case.idx[[p]], Mp$pat[p, ], drop = FALSE]

    # if complete, just compute first and second moments
    if (all(var.idx)) {
      if (!is.null(wt)) {
        WT <- wt[Mp$case.idx[[p]]]
        T1 <- T1 + colSums(WT * O)
        T2 <- T2 + crossprod(sqrt(WT) * O)
      } else {
        # complete pattern
        T1 <- T1 + colSums(O)
        T2 <- T2 + crossprod(O)
      }
      next
    }

    # missing values for this pattern
    na.idx <- which(!var.idx)

    # partition Sigma (1=missing, 2=complete)
    Sigma_11 <- Sigma[!var.idx, !var.idx, drop = FALSE]
    Sigma_12 <- Sigma[!var.idx, var.idx, drop = FALSE]
    Sigma_21 <- Sigma[var.idx, !var.idx, drop = FALSE]

    # invert Sigma (Sigma_22, observed part only) for this pattern
    Sigma_22.inv <- try(
      lav_matrix_symmetric_inverse_update(
        S.inv =
          Sigma.inv, rm.idx = na.idx, logdet = FALSE
      ),
      silent = TRUE
    )
    if (inherits(Sigma_22.inv, "try-error")) {
      lav_msg_stop(gettext("Sigma_22.inv cannot be inverted"))
    }

    # estimate missing values in this pattern
    Oc <- t(t(O) - Mu[var.idx])
    Y.missing <- t(Sigma_12 %*% Sigma_22.inv %*% t(Oc) + Mu[!var.idx])

    # complete data for this pattern
    Y.complete <- matrix(0, Mp$freq[[p]], P)
    Y.complete[, var.idx] <- O
    Y.complete[, !var.idx] <- Y.missing

    if (!is.null(wt)) {
      WT <- wt[Mp$case.idx[[p]]]
      T1.pat <- colSums(WT * Y.complete)
      T2.pat <- crossprod(sqrt(WT) * Y.complete)
    } else {
      # 1. SUM `completed' pattern
      T1.pat <- colSums(Y.complete)

      # 2. CROSSPROD `completed' pattern
      T2.pat <- crossprod(Y.complete)
    }

    # correction for missing cells: conditional covariances
    T2.p11 <- Sigma_11 - (Sigma_12 %*% Sigma_22.inv %*% Sigma_21)
    if (!is.null(wt)) {
      T2.pat[!var.idx, !var.idx] <-
        T2.pat[!var.idx, !var.idx] + (T2.p11 * sum(WT))
    } else {
      T2.pat[!var.idx, !var.idx] <-
        T2.pat[!var.idx, !var.idx] + (T2.p11 * Mp$freq[[p]])
    }

    # accumulate
    T1 <- T1 + T1.pat
    T2 <- T2 + T2.pat
  }

  list(T1 = T1, T2 = T2)
}

# utility functions
#
# initial version: YR 25/03/2009

# multivariate normal random number generation
# replacement for MASS::mvrnorm for better cross-machine reproducibility
# see: https://blog.djnavarro.net/posts/2025-05-18_multivariate-normal-sampling-floating-point/
#
# the issue with MASS::mvrnorm is that it uses eigendecomposition with a
# transformation matrix (sqrt(Lambda) Q') that is NOT invariant to eigenvector
# sign flips. this leads to irreproducible results across machines even with
# the same random seed. this implementation follows mvtnorm::rmvnorm which uses:
# - eigen: Q sqrt(Lambda) Q' which IS invariant to sign flips (default)
# - svd: similar to eigen, also invariant
# - chol: unique factorization
# eigen is the default to match MASS::mvrnorm's approach while fixing the
# sign-flip issue with the invariant formula
lav_mvrnorm <- function(n = 1, mu, Sigma, tol = 1e-06, empirical = FALSE,
                        method = "eigen", checkSymmetry = TRUE, byrow = FALSE) {
  p <- length(mu)

  # check symmetry (like mvtnorm)
  if (checkSymmetry && !isSymmetric(Sigma,
    tol = sqrt(.Machine$double.eps),
    check.attributes = FALSE
  )) {
    lav_msg_stop(gettext("'Sigma' must be a symmetric matrix in lav_mvrnorm"))
  }

  # check dimensions (like mvtnorm)
  if (p != nrow(Sigma)) {
    lav_msg_stop(gettext("incompatible arguments in lav_mvrnorm"))
  }

  # compute transformation matrix R based on method (following mvtnorm exactly)
  method <- match.arg(method, c("chol", "eigen", "svd"))

  R <- if (method == "eigen") {
    ev <- eigen(Sigma, symmetric = TRUE)
    if (!all(ev$values >= -tol * abs(ev$values[1L]))) {
      warning("sigma is numerically not positive semidefinite")
    }
    # Q sqrt(Lambda) Q' - invariant to sign flips
    t(ev$vectors %*% (t(ev$vectors) * sqrt(pmax(ev$values, 0))))
  } else if (method == "svd") {
    s. <- svd(Sigma)
    if (!all(s.$d >= -tol * abs(s.$d[1L]))) {
      warning("sigma is numerically not positive semidefinite")
    }
    t(s.$v %*% (t(s.$u) * sqrt(pmax(s.$d, 0))))
  } else if (method == "chol") {
    R <- chol(Sigma, pivot = TRUE)
    R[, order(attr(R, "pivot"))]
  }

  # for names (fallback to dimnames of Sigma if mu has no names)
  nm <- names(mu)
  if (is.null(nm) && !is.null(dn <- dimnames(Sigma))) {
    nm <- dn[[1L]]
  }

  if (empirical) {
    # generate standard normal, then apply empirical transformation
    X <- matrix(stats::rnorm(p * n), n, p, byrow = byrow)
    X <- scale(X, center = TRUE, scale = FALSE) # center
    X <- X %*% svd(X, nu = 0)$v # orthogonalize
    X <- scale(X, center = FALSE, scale = TRUE) # unit variance

    # transform by R
    X <- sweep(X %*% R, 2, mu, "+")
    colnames(X) <- nm

    if (n == 1) drop(X) else X
  } else {
    # generate samples (following mvtnorm exactly)
    X <- matrix(stats::rnorm(n * p), nrow = n, byrow = byrow) %*% R
    X <- sweep(X, 2, mu, "+")
    colnames(X) <- nm

    if (n == 1) drop(X) else X
  }
}

# outlier detection based on inter-quartile range
# same as boxplot.stats, but returning the indices (not the values)
lav_sample_outlier_idx <- function(x, coef = 1.5) {
  if (coef < 0) {
    lav_msg_stop(gettext("'coef' must not be negative"))
  }
  stats <- stats::fivenum(x, na.rm = TRUE)
  iqr <- diff(stats[c(2, 4)])
  if (coef == 0) {
    return(seq_len(length(x)))
  } else {
    out <- if (!is.na(iqr)) {
      which(x < (stats[2L] - coef * iqr) | x > (stats[4L] + coef * iqr))
    } else {
      which(!is.finite(x))
    }
  }
  out
}

# sd with trimming
lav_sample_trimmed_sd <- function(x, na.rm = TRUE, trim = 0) {
  if (isTRUE(na.rm)) {
    x <- x[!is.na(x)]
  }
  n <- length(x)
  if (trim > 0 && n) {
    if (is.complex(x)) {
      lav_msg_stop(gettext("trimmed means are not defined for complex data"))
    }
    if (anyNA(x)) {
      return(NA_real_)
    }
    if (trim >= 0.5) {
      return(stats::median(x, na.rm = FALSE))
    }
    lo <- floor(n * trim) + 1
    hi <- n + 1 - lo
    x <- sort.int(x, partial = unique(c(lo, hi)))[lo:hi]
  }
  sd(x)
}

# mdist = Mahalanobis distance
lav_sample_mdist <- function(Y, Mp = NULL, wt = NULL,
                             Mu = NULL, Sigma = NULL,
                             Sinv.method = "eigen", ginv = TRUE,
                             rescale = FALSE) {
  # check input
  Y <- as.matrix(Y)
  P <- NCOL(Y)
  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }
  NY <- NROW(Y)

  # missing data?
  missing.flag <- anyNA(Y)

  # missing patterns?
  if (missing.flag && is.null(Mp)) {
    Mp <- lav_data_missing_patterns(Y)
  }

  # no Mu? compute sample mean
  if (is.null(Mu)) {
    Mu <- colMeans(Y, na.rm = TRUE)
  }

  # no Sigma?
  if (is.null(Sigma)) {
    if (missing.flag) {
      out <- lav_mvnorm_missing_h1_estimate_moments(
        Y = Y, Mp = Mp,
        wt = wt
      )
      Mu <- out$Mu
      Sigma <- out$Sigma
    } else {
      if (!is.null(wt)) {
        out <- stats::cov.wt(Y, wt = wt, method = "ML")
        Sigma <- out$cov
        Mu <- out$center
      } else {
        Sigma <- stats::cov(Y, use = "pairwise")
        # rescale?
        if (rescale) {
          Sigma <- ((N - 1) / N) * Sigma
        }
      }
    }
  }

  # subtract Mu
  Yc <- t(t(Y) - Mu)

  # DIST per case
  DIST <- rep(as.numeric(NA), NY)

  # invert Sigma
  if (ginv) {
    Sigma.inv <- MASS::ginv(Sigma)
  } else {
    Sigma.inv <-
      try(
        lav_matrix_symmetric_inverse(
          S = Sigma, logdet = FALSE,
          Sinv.method = Sinv.method
        ),
        silent = TRUE
      )
    if (inherits(Sigma.inv, "try-error")) {
      lav_msg_warn(gettext(
        "problem computing distances: could not invert Sigma"
      ))
      return(DIST)
    }
  }

  # complete data?
  if (!missing.flag) {
    # center factor scores
    Y.c <- t(t(Y) - Mu)
    # Mahalobis distance
    DIST <- rowSums((Y.c %*% Sigma.inv) * Y.c)

    # missing data?
  } else {
    # for each pattern, compute sigma.inv; compute DIST for all
    # observations of this pattern
    for (p in seq_len(Mp$npatterns)) {
      # observed values for this pattern
      var.idx <- Mp$pat[p, ]

      # missing values for this pattern
      na.idx <- which(!var.idx)

      # identify cases with this pattern
      case.idx <- Mp$case.idx[[p]]

      # invert Sigma for this pattern
      if (length(na.idx) > 0L) {
        if (ginv) {
          sigma.inv <- MASS::ginv(Sigma[-na.idx, -na.idx, drop = FALSE])
        } else {
          sigma.inv <-
            lav_matrix_symmetric_inverse_update(
              S.inv = Sigma.inv,
              rm.idx = na.idx, logdet = FALSE
            )
        }
      } else {
        sigma.inv <- Sigma.inv
      }

      if (Mp$freq[p] == 1L) {
        DIST[case.idx] <- sum(sigma.inv *
          crossprod(Yc[case.idx, var.idx, drop = FALSE]))
      } else {
        DIST[case.idx] <-
          rowSums(Yc[case.idx, var.idx, drop = FALSE] %*% sigma.inv *
            Yc[case.idx, var.idx, drop = FALSE])
      }
    } # patterns
  } # missing data

  # use weights? (no for now)
  # DIST <- DIST * wt

  DIST
}

# convert correlation matrix + standard deviations to covariance matrix
# based on cov2cor in package:stats
lav_cor2cov <- function(R, sds, names = NULL) {
  p <- (d <- dim(R))[1L]
  if (!is.numeric(R) || length(d) != 2L || p != d[2L]) {
    lav_msg_stop(gettext("'V' is not a square numeric matrix"))
  }

  if (any(!is.finite(sds))) {
    lav_msg_warn(gettext(
      "sds had 0 or NA entries; non-finite result is doubtful"
    ))
  }

  # if(sum(diag(R)) != p)
  #    stop("The diagonal of a correlation matrix should be all ones.")

  if (p != length(sds)) {
    lav_msg_stop(gettext("The standard deviation vector and correlation matrix
                         have a different number of variables"))
  }

  S <- R
  S[] <- sds * R * rep(sds, each = p)

  # optionally, add names
  if (!is.null(names)) {
    stopifnot(length(names) == p)
    rownames(S) <- colnames(S) <- names
  }

  S
}

# convert characters within single quotes to numeric vector
# eg. s <- '3 4.3 8e-3 2.0'
#     x <- lav_char2num(s)
lav_char2num <- function(s = "") {
  # first, strip all ',' or ';'
  s. <- gsub(",", " ", s)
  s. <- gsub(";", " ", s.)
  tc <- textConnection(s.)
  x <- scan(tc, quiet = TRUE)
  close(tc)
  x
}

# create full matrix based on lower.tri or upper.tri elements; add names
# always ROW-WISE!!
lav_getcov <- function(x, lower = TRUE, diagonal = TRUE, sds = NULL,
                       names = paste("V", 1:nvar, sep = "")) {
  # check x and sds
  if (is.character(x)) x <- lav_char2num(x)
  if (is.character(sds)) sds <- lav_char2num(sds)

  nels <- length(x)
  if (lower) {
    COV <- lav_matrix_lower2full(x, diagonal = diagonal)
  } else {
    COV <- lav_matrix_upper2full(x, diagonal = diagonal)
  }
  nvar <- ncol(COV)

  # if diagonal is false, assume unit diagonal
  if (!diagonal) diag(COV) <- 1

  # check if we have a sds argument
  if (!is.null(sds)) {
    stopifnot(length(sds) == nvar)
    COV <- lav_cor2cov(COV, sds)
  }

  # names
  stopifnot(length(names) == nvar)
  rownames(COV) <- colnames(COV) <- names

  COV
}

lav_char2hash <- function(s = "") {
  stopifnot(is.character(s))
  nums <- utf8ToInt(paste(s, collapse = "\n"))
  rval <- 0x7EDCBA98L
  for (i in nums) {
    positions <- 1L + (bitwAnd(i, 15L))
    bitsR <- bitwShiftL(1L, positions) - 1L
    wrap1 <- bitwShiftL(bitwAnd(bitsR, rval), 31L - positions)
    wrap2 <- bitwShiftR(bitwAnd(bitwNot(bitsR), rval), positions)
    saw <- bitwOr(wrap1, wrap2)
    rval <- bitwXor(saw, i)
  }
  as.hexmode(rval)
}

# vectorize all (h0 or h1) sample statistics, in the same order
# as Gamma
lav_implied_to_vec <- function(implied = NULL, lavmodel = NULL,
                               drop.list = TRUE) {
  ngroups <- lavmodel@ngroups

  wls_obs <- vector("list", ngroups)
  for (g in seq_len(ngroups)) {

    var <- NULL
    res.var <- NULL
    if (lavmodel@conditional.x) {
      res.var <- diag(implied$res.cov[[g]])
      res.var <- res.var[res.var != 1]
    } else {
      var <- diag(implied$cov[[g]])
      var <- var[var != 1]
    }

    wls_obs[[g]] <- lav_samplestats_wls_obs(
      # plain
      mean.g = implied$mean[[g]],
      cov.g = implied$cov[[g]],
      var.g = var,
      th.g = implied$th[[g]],
      th.idx.g = lavmodel@th.idx[[g]],

      # conditional.x
      res.int.g = implied$res.int[[g]],
      res.cov.g = implied$res.cov[[g]],
      res.var.g = res.var,
      res.th.g = implied$res.th[[g]],
      res.slopes.g = implied$res.slopes[[g]],
      group.w.g = implied$group.w[[g]],

      # flags
      categorical = lavmodel@categorical,
      conditional.x = lavmodel@conditional.x,
      meanstructure = lavmodel@meanstructure,
      correlation = lavmodel@correlation,
      slopestructure = lavmodel@conditional.x,
      group.w.free = lavmodel@group.w.free
    )
  }

  if (drop.list) {
    out <- unlist(wls_obs)
  } else {
    out <- wls_obs
  }

  out
}

# given a vector of sample statistics, reconstruct implied
# entries (cov, mean, th, res.cov, ...)
lav_vec_to_implied <- function(x = NULL, lavmodel) {

  ngroups <- lavmodel@ngroups
  implied <- list()

  for (g in seq_len(ngroups)) {

    # number of variables
    nvar <- lavmodel@nvar[g]

    # if group.w.free, always comes first
    if (lavmodel@group.w.free) {
      idx <- 1L
      group.w <- x[idx]
      x <- x[-idx]
    } else {
      group.w <- 1
    }

    if (lavmodel@categorical) {
      # TODO
      cat("\n NOT READY YET! \n")
    } else {
      # diag flag
      diag_flag <- TRUE
      if (lavmodel@correlation) {
        diag_flag <- FALSE
      }
      if (lavmodel@conditional.x) {
        # TODO
        cat("\n NOT READY YET! \n")
      }
      if (lavmodel@meanstructure) {
        idx <- seq_len(nvar)
        mean_g <- x[idx]
        x <- x[-idx]
      } else {
        mean_g <- numeric(nvar)
      }
      if (diag_flag) {
        idx <- seq_len( nvar * (nvar + 1) / 2 )
      } else {
        idx <- seq_len( nvar * (nvar - 1) / 2 )
      }
      cov_g <- lav_matrix_vech_reverse(x[idx], diagonal = diag_flag)
      x <- x[-idx]

      # fill in
      implied$cov[[g]] <- cov_g
      implied$mean[[g]] <- mean_g
      implied$th[g] <- list(NULL)
    }

    implied$group.w[[g]] <- group.w
  }

  implied
}

# here, we compute various versions of the `information' matrix
# NOTE:
# 1) we ALWAYS compute the UNIT information (not the total information)
#
# 2) by default, we ignore the constraints (we deal with this when we
#    take the inverse later on)

lav_model_information <- function(lavmodel = NULL,
                                  lavsamplestats = NULL,
                                  lavdata = NULL,
                                  lavimplied = NULL,
                                  lavh1 = NULL,
                                  Delta = NULL,
                                  lavcache = NULL,
                                  lavoptions = NULL,
                                  extra = FALSE,
                                  augmented = FALSE,
                                  inverted = FALSE,
                                  use.ginv = FALSE) {

  information <- lavoptions$information[1] # ALWAYS used the first one
  # caller can control it

  # rotation?
  # if(!is.null(lavoptions$rotation) && lavoptions$rotation != "none") {
  #    use.ginv <- TRUE
  # }

  if (is.null(lavh1)) {
    lavh1 <- lav_h1_implied_logl(
      lavdata = lavdata,
      lavsamplestats = lavsamplestats,
      lavoptions = lavoptions
    )
  }

  # compute information matrix
  if (information == "observed") {
    if (lavsamplestats@missing.flag || lavdata@nlevels > 1L) {
      group.weight <- FALSE
    } else {
      group.weight <- TRUE
    }
    E <- lav_model_information_observed(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavimplied = lavimplied, lavh1 = lavh1,
      lavcache = lavcache, group.weight = group.weight,
      lavoptions = lavoptions, extra = extra,
      augmented = augmented, inverted = inverted, use.ginv = use.ginv
    )
  } else if (information == "expected") {
    E <- lav_model_information_expected(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavimplied = lavimplied, lavh1 = lavh1,
      lavcache = lavcache, lavoptions = lavoptions, extra = extra,
      augmented = augmented, inverted = inverted, use.ginv = use.ginv
    )
  } else if (information == "first.order") {
    E <- lav_model_information_firstorder(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavimplied = lavimplied, lavh1 = lavh1,
      lavcache = lavcache, lavoptions = lavoptions, # extra = extra,
      check.pd = FALSE,
      augmented = augmented, inverted = inverted, use.ginv = use.ginv
    )
  }

  # information, augmented information, or inverted information
  E
}

# fisher/expected information
#
# information = Delta' I1 Delta, where I1 is the unit information of
# the saturated model (evaluated either at the structured or unstructured
# estimates)
lav_model_information_expected <- function(lavmodel = NULL,
                                           lavsamplestats = NULL,
                                           lavdata = NULL,
                                           lavoptions = NULL,
                                           lavimplied = NULL,
                                           lavh1 = NULL,
                                           Delta = NULL,
                                           lavcache = NULL,
                                           extra = FALSE,
                                           augmented = FALSE,
                                           inverted = FALSE,
                                           use.ginv = FALSE) {
  if (inverted) {
    augmented <- TRUE
  }

  # 1. Delta
  if (is.null(Delta)) {
    Delta <- lav_model_delta(lavmodel = lavmodel)
  }


  # 2. H1 information (single level)
  if (lavdata@nlevels == 1L) {
    A1 <- lav_model_h1_information_expected(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats,
      lavdata = lavdata,
      lavoptions = lavoptions,
      lavimplied = lavimplied,
      lavh1 = lavh1,
      lavcache = lavcache
    )
  } else {
    # force conditional.x = FALSE
    lavimplied <- lav_model_implied_cond2uncond(lavimplied)
  }

  # 3. compute Information per group
  Info.group <- vector("list", length = lavsamplestats@ngroups)
  for (g in 1:lavsamplestats@ngroups) {
    # note LISREL documentation suggests (Ng - 1) instead of Ng...
    fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal

    # multilevel
    if (lavdata@nlevels > 1L) {
      # here, we assume only 2 levels, at [[1]] and [[2]]
      if (lavoptions$h1.information[1] == "structured") {
        Sigma.W <- lavimplied$cov[[(g - 1) * 2 + 1]]
        Mu.W <- lavimplied$mean[[(g - 1) * 2 + 1]]
        Sigma.B <- lavimplied$cov[[(g - 1) * 2 + 2]]
        Mu.B <- lavimplied$mean[[(g - 1) * 2 + 2]]
      } else {
        Sigma.W <- lavh1$implied$cov[[(g - 1) * 2 + 1]]
        Mu.W <- lavh1$implied$mean[[(g - 1) * 2 + 1]]
        Sigma.B <- lavh1$implied$cov[[(g - 1) * 2 + 2]]
        Mu.B <- lavh1$implied$mean[[(g - 1) * 2 + 2]]
      }
      Lp <- lavdata@Lp[[g]]

      Info.g <-
        lav_mvnorm_cluster_information_expected_delta(
          Lp = Lp,
          Delta = Delta[[g]],
          Mu.W = Mu.W,
          Sigma.W = Sigma.W,
          Mu.B = Mu.B,
          Sigma.B = Sigma.B,
          Sinv.method = "eigen"
        )
      Info.group[[g]] <- fg * Info.g
    } else {
      # compute information for this group
      if (lavmodel@estimator %in% c("DWLS", "ULS")) {
        # diagonal weight matrix
        Delta2 <- sqrt(A1[[g]]) * Delta[[g]]
        Info.group[[g]] <- fg * crossprod(Delta2)
      } else {
        # full weight matrix
        # if (lav_use_lavaanC()) {
        # # (i) use of m_crossprod with sparse matrix on the left:
        # # Info.group[[g]] <- fg * lavaanC::m_crossprod(Delta[[g]],
        # #                     lavaanC::m_prod(A1[[g]], Delta[[g]], "R"), "L")
        # #
        # # (ii) use of m_prod on transposed sparse first matrix, faster than (i):
        #   Info.group[[g]] <- fg * lavaanC::m_prod(t(Delta[[g]]),
        #                       lavaanC::m_prod(A1[[g]], Delta[[g]], "R"), "L")
        # } else {
          Info.group[[g]] <-
            fg * (crossprod(Delta[[g]], A1[[g]]) %*% Delta[[g]])
        # }
      }
    }
  } # g

  # 4. assemble over groups
  Information <- Info.group[[1]]
  if (lavsamplestats@ngroups > 1) {
    for (g in 2:lavsamplestats@ngroups) {
      Information <- Information + Info.group[[g]]
    }
  }

  # 5. augmented information?
  if (augmented) {
    Information <-
      lav_model_information_augment_invert(
        lavmodel = lavmodel,
        information = Information,
        inverted = inverted,
        use.ginv = use.ginv
      )
  }

  if (extra) {
    attr(Information, "Delta") <- Delta
    attr(Information, "WLS.V") <- A1 # unweighted
  }

  # possibly augmented/inverted
  Information
}

# only for Mplus MLM
lav_model_information_expected_MLM <- function(lavmodel = NULL,
                                               lavsamplestats = NULL,
                                               Delta = NULL,
                                               extra = FALSE,
                                               augmented = FALSE,
                                               inverted = FALSE,
                                               use.ginv = FALSE) {
  if (inverted) {
    augmented <- TRUE
  }

  if (is.null(Delta)) {
    Delta <- lav_model_delta(lavmodel = lavmodel)
  }

  # compute A1
  A1 <- vector("list", length = lavsamplestats@ngroups)
  if (lavmodel@group.w.free) {
    GW <- unlist(lav_model_gw(lavmodel = lavmodel))
  }
  for (g in 1:lavsamplestats@ngroups) {
    A1[[g]] <- lav_mvnorm_h1_information_expected(
      sample.cov     = lavsamplestats@cov[[g]],
      sample.cov.inv = lavsamplestats@icov[[g]],
      x.idx          = lavsamplestats@x.idx[[g]]
    )
    # the same as GLS... (except for the N/N-1 scaling)
    if (lavmodel@group.w.free) {
      # unweight!!
      a <- exp(GW[g]) / lavsamplestats@nobs[[g]]
      # a <- exp(GW[g]) * lavsamplestats@ntotal / lavsamplestats@nobs[[g]]
      A1[[g]] <- lav_matrix_bdiag(matrix(a, 1, 1), A1[[g]])
    }
  }

  # compute Information per group
  Info.group <- vector("list", length = lavsamplestats@ngroups)
  for (g in 1:lavsamplestats@ngroups) {
    fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal
    # compute information for this group
    Info.group[[g]] <- fg * (t(Delta[[g]]) %*% A1[[g]] %*% Delta[[g]])
  }

  # assemble over groups
  Information <- Info.group[[1]]
  if (lavsamplestats@ngroups > 1) {
    for (g in 2:lavsamplestats@ngroups) {
      Information <- Information + Info.group[[g]]
    }
  }

  # augmented information?
  if (augmented) {
    Information <-
      lav_model_information_augment_invert(
        lavmodel = lavmodel,
        information = Information,
        inverted = inverted,
        use.ginv = use.ginv
      )
  }

  if (extra) {
    attr(Information, "Delta") <- Delta
    attr(Information, "WLS.V") <- A1 # unweighted
  }

  Information
}


lav_model_information_observed <- function(lavmodel = NULL,
                                           lavsamplestats = NULL,
                                           lavdata = NULL,
                                           lavimplied = NULL,
                                           lavh1 = NULL,
                                           lavcache = NULL,
                                           lavoptions = NULL,
                                           extra = FALSE,
                                           group.weight = TRUE,
                                           augmented = FALSE,
                                           inverted = FALSE,
                                           use.ginv = FALSE) {
  if (inverted) {
    augmented <- TRUE
  }

  # observed.information:
  #     - "hessian": second derivative of objective function
  #     - "h1": observed information matrix of saturated (h1) model,
  #             pre- and post-multiplied by the jacobian of the model
  #             parameters (Delta), usually evaluated at the structured
  #             sample statistics (but this depends on the h1.information
  #             option)
  if (!is.null(lavoptions) &&
    !is.null(lavoptions$observed.information[1]) &&
    lavoptions$observed.information[1] == "h1") {
    observed.information <- "h1"
  } else {
    observed.information <- "hessian"
  }

  # HESSIAN based
  if (observed.information == "hessian") {
    Hessian <- lav_model_hessian(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats,
      lavdata = lavdata,
      lavoptions = lavoptions,
      lavcache = lavcache,
      group.weight = group.weight,
      ceq.simple = FALSE
    )

    # NOTE! What is the relationship between the Hessian of the objective
    # function, and the `information' matrix (unit or total)

    # 1. in lavaan, we ALWAYS minimize, so the Hessian is already pos def
    # 2. currently, all estimators give unit information, except MML and PML
    #    so, no need to divide by N
    Information <- Hessian

    # divide by 'N' for MML and PML
    if (lavmodel@estimator == "PML" || lavmodel@estimator == "MML") {
      Information <- Information / lavsamplestats@ntotal
      # HJ: Does this need to be divided by sum of weights instead?
    }

    # if multilevel, we should divide by 'J', the number of clusters
    if (lavdata@nlevels > 1L) {
      NC <- 0
      for (g in 1:lavsamplestats@ngroups) {
        NC <- NC + lavdata@Lp[[g]]$nclusters[[2]]
      }
      Information <- Information * lavsamplestats@ntotal / NC
    }
  }

  # using 'observed h1 information'
  # we need DELTA and 'WLS.V' (=A1)

  if (observed.information == "h1" || extra) {
    # 1. Delta
    Delta <- lav_model_delta(lavmodel = lavmodel)

    # 2. H1 information

    A1 <- lav_model_h1_information_observed(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats,
      lavdata = lavdata,
      lavoptions = lavoptions,
      lavimplied = lavimplied,
      lavh1 = lavh1,
      lavcache = lavcache
    )
  }

  if (observed.information == "h1") {
    # compute Information per group
    Info.group <- vector("list", length = lavsamplestats@ngroups)
    for (g in 1:lavsamplestats@ngroups) {
      fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal
      # compute information for this group
      if (lavmodel@estimator %in% c("DWLS", "ULS")) {
        # diagonal weight matrix
        Delta2 <- sqrt(A1[[g]]) * Delta[[g]]
        Info.group[[g]] <- fg * crossprod(Delta2)
      } else {
        # full weight matrix
        Info.group[[g]] <-
          fg * (crossprod(Delta[[g]], A1[[g]]) %*% Delta[[g]])
      }
    }

    # assemble over groups
    Information <- Info.group[[1]]
    if (lavsamplestats@ngroups > 1) {
      for (g in 2:lavsamplestats@ngroups) {
        Information <- Information + Info.group[[g]]
      }
    }
  }

  # augmented information?
  if (augmented) {
    Information <-
      lav_model_information_augment_invert(
        lavmodel = lavmodel,
        information = Information,
        inverted = inverted,
        use.ginv = use.ginv
      )
  }

  if (extra) {
    attr(Information, "Delta") <- Delta
    attr(Information, "WLS.V") <- A1
  }

  Information
}

# outer product of the case-wise scores (gradients)
# HJ 18/10/23: Need to divide sum of crossproduct of individual log-likelihoods
# by sum of weights rather than sample size.
lav_model_information_firstorder <- function(lavmodel = NULL,
                                             lavsamplestats = NULL,
                                             lavdata = NULL,
                                             lavimplied = NULL,
                                             lavh1 = NULL,
                                             lavcache = NULL,
                                             lavoptions = NULL,
                                             check.pd = FALSE,
                                             extra = FALSE,
                                             augmented = FALSE,
                                             inverted = FALSE,
                                             use.ginv = FALSE) {
  if (!lavmodel@estimator %in% c("ML", "PML")) {
    lav_msg_stop(gettext(
      "information = \"first.order\" not available for estimator"),
      sQuote(lavmodel@estimator))
  }

  if (inverted) {
    augmented <- TRUE
  }

  B0.group <- vector("list", lavsamplestats@ngroups)

  # 1. Delta
  Delta <- lav_model_delta(lavmodel = lavmodel)

  # 2. H1 information
  B1 <- lav_model_h1_information_firstorder(
    lavmodel = lavmodel,
    lavsamplestats = lavsamplestats,
    lavdata = lavdata,
    lavoptions = lavoptions,
    lavimplied = lavimplied,
    lavh1 = lavh1,
    lavcache = lavcache
  )

  # 3. compute Information per group
  Info.group <- vector("list", length = lavsamplestats@ngroups)
  for (g in 1:lavsamplestats@ngroups) {
    # unweighted (needed in lav_test?)
    B0.group[[g]] <- t(Delta[[g]]) %*% B1[[g]] %*% Delta[[g]]

    # >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    # NOTE: UNSURE ABOUT THIS PART. WHAT IS THE ROLE OF fg?

    wt <- lavdata@weights[[g]]
    if (is.null(wt)) {
      fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal
    } else {
      totalwt <- sum(unlist(lavdata@weights))
      fg <- sum(wt) / totalwt
    }

    # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    # compute information for this group
    Info.group[[g]] <- fg * B0.group[[g]]
  }

  # 4. assemble over groups
  Information <- Info.group[[1]]
  if (lavsamplestats@ngroups > 1) {
    for (g in 2:lavsamplestats@ngroups) {
      Information <- Information + Info.group[[g]]
    }
  }

  # NOTE: for MML and PML, we get 'total' information (instead of unit) divide
  # by 'N' for MML and PML. For weighted sample, use the sum of weights
  # instead of sample size

  # >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

  if (lavmodel@estimator == "PML" || lavmodel@estimator == "MML") {
    if (length(lavdata@sampling.weights) == 0) {
      the_N <- lavsamplestats@ntotal
    } else {
      the_N <- sum(unlist(lavdata@weights))
    }
    Information <- Information / the_N
    for (g in 1:lavsamplestats@ngroups) {
      B0.group[[g]] <- B0.group[[g]] / the_N
    }
  }
  # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

  # augmented information?
  if (augmented) {
    Information <-
      lav_model_information_augment_invert(
        lavmodel = lavmodel,
        information = Information,
        check.pd = check.pd,
        inverted = inverted,
        use.ginv = use.ginv
      )
  }

  if (extra) {
    attr(Information, "B0.group") <- B0.group
    attr(Information, "Delta") <- Delta
    attr(Information, "WLS.V") <- B1
  }

  Information
}


# create augmented information matrix (if needed), and take the inverse
# (if inverted = TRUE), returning only the [1:npar, 1:npar] elements
#
# rm.idx is used by lav_sam_step2_se; it used when the structural model
# contains more parameters than the joint model; therefore, information
# will be 'too small', and we need to remove some columns in H
#
lav_model_information_augment_invert <- function(lavmodel = NULL,
                                                 information = NULL,
                                                 inverted = FALSE,
                                                 check.pd = FALSE,
                                                 use.ginv = FALSE,
                                                 rm.idx = integer(0L)) {
  npar <- nrow(information)
  is.augmented <- FALSE

  # handle constraints
  if (nrow(lavmodel@con.jac) > 0L) {
    H <- lavmodel@con.jac
    if (length(rm.idx) > 0L) {
      H <- H[, -rm.idx, drop = FALSE]
    }
    inactive.idx <- attr(H, "inactive.idx")
    lambda <- lavmodel@con.lambda # lagrangean coefs
    if (length(inactive.idx) > 0L) {
      H <- H[-inactive.idx, , drop = FALSE]
      lambda <- lambda[-inactive.idx]
    }
    if (nrow(H) > 0L) {
      is.augmented <- TRUE
      H0 <- matrix(0, nrow(H), nrow(H))
      H10 <- matrix(0, ncol(information), nrow(H))
      DL <- 2 * diag(lambda, nrow(H), nrow(H))
      # FIXME: better include inactive + slacks??
      # INFO <- information
      # or
      INFO <- information + crossprod(H)
      E3 <- rbind(
        cbind(INFO, H10, t(H)),
        cbind(t(H10), DL, H0),
        cbind(H, H0, H0)
      )
      information <- E3
    }
  } else if (lavmodel@ceq.simple.only) {
    H <- t(lav_matrix_orthogonal_complement(lavmodel@ceq.simple.K))
    if (length(rm.idx) > 0L) {
      H <- H[, -rm.idx, drop = FALSE]
    }
    if (nrow(H) > 0L) {
      is.augmented <- TRUE
      H0 <- matrix(0, nrow(H), nrow(H))
      H10 <- matrix(0, ncol(information), nrow(H))
      INFO <- information + crossprod(H)
      E2 <- rbind(
        cbind(INFO, t(H)),
        cbind(H, H0)
      )
      information <- E2
    }
  }

  if (check.pd) {
    eigvals <- eigen(information,
      symmetric = TRUE,
      only.values = TRUE
    )$values
    if (any(eigvals < -1 * .Machine$double.eps^(3 / 4))) {
      lav_msg_warn(gettext(
        "information matrix is not positive definite;
        the model may not be identified"))
    }
  }

  if (inverted) {
    if (is.augmented) {
      # note: default tol in MASS::ginv is sqrt(.Machine$double.eps)
      #       which seems a bit too conservative
      #       from 0.5-20, we changed this to .Machine$double.eps^(3/4)
      information <-
        try(
          MASS::ginv(information,
            tol = .Machine$double.eps^(3 / 4)
          )[1:npar,
            1:npar,
            drop = FALSE
          ],
          silent = TRUE
        )
    } else {
      if (use.ginv) {
        information <- try(
          MASS::ginv(information,
            tol = .Machine$double.eps^(3 / 4)
          ),
          silent = TRUE
        )
      } else {
        information <- try(solve(information), silent = TRUE)
      }
    }
  }

  # augmented/inverted information
  information
}

lav_model_information_expected_2l <- function(lavmodel = NULL,
                                              lavsamplestats = NULL,
                                              lavdata = NULL,
                                              lavoptions = NULL,
                                              lavimplied = NULL,
                                              lavh1 = NULL,
                                              g = 1L) {
  # see Yuan & Bentler (2002), p.549 top line
  # I.j = nj. Delta.mu' sigma.j.inv +
  #       Delta.sigma.j' W.j Delta.sigma.j +
  #       (nj-1) Delta.sigma.w' W.w Delta.sigma.w
  #
  # where
  # - sigma.j = sigma.w + n.j * sigma.b
  # - W.w = 1/2 * D'(sigma.w.inv %x% sigma.w.inv) D
  # - W.j = 1/2 * D'(sigma.j.inv %x% sigma.j.inv) D
}

lav_lavaan_step01_ovnames_initflat <- function(slotParTable     = NULL, # nolint
                                               model            = NULL,
                                               dotdotdot.parser = "new") {
  # if slotPartable not NULL copy to flat.model
  # else
  #   if model is of type character
  #     parse model to flat.model
  #   else if model is a formula (** warning **)
  #     transform "~ x1 + x2 + x3" to character "f =~ x1 + x2 + x3",
  #         and parse to flat.model
  #     transform "y =~ x1 + x2 + x3" to character and parse to flat.model
  #     something else : *** error ***
  #   else if model is a lavaan object
  #     extract flat.model from @parTable
  #   else if model is a list
  #     if bare minimum present (columns lhs, op, rhs, free)
  #        flat.model = model
  #        replace column block by column group (if present)
  #     else
  #        --> *** error ***
  #   else
  #     --> ***error***
  #

  # 1a. get ov.names and ov.names.x (per group) -- needed for lav_lavdata()
  if (!is.null(slotParTable)) {
    flat.model <- slotParTable
  } else if (is.character(model)) {
    if (is.null(dotdotdot.parser)) {
      flat.model <- lavParseModelString(model, parser = "new")
    } else {
      flat.model <- lavParseModelString(model, parser = dotdotdot.parser)
    }
  } else if (inherits(model, "formula")) {
    # two typical cases:
    # 1. regression type formula
    # 2. no quotes, e.g. f =~ x1 + x2 + x3
    #    TODO: this isn't a valid formula !!!
    tmp <- as.character(model)
    if (tmp[1] == "~" && length(tmp) == 2L) {
      # looks like an unquoted single factor model f =~ something
      lav_msg_warn(
        gettext("model seems to be a formula;
                please enclose the model syntax between quotes"))
      # create model and hope for the best
      model.bis <- paste("f =", paste(tmp, collapse = " "), sep = "")
      flat.model <- lavParseModelString(model.bis)
    } else if (tmp[1] == "~" && length(tmp) == 3L) {
      # looks like a (unquoted) regression formula
      lav_msg_warn(
        gettext("model seems to be a formula;
                please enclose the model syntax between quotes"))
      # create model and hope for the best
      model.bis <- paste(tmp[2], tmp[1], tmp[3])
      flat.model <- lavParseModelString(model.bis)
    } else {
      lav_msg_stop(
        gettext("model seems to be a formula;
                please enclose the model syntax between quotes"))
    }
  } else if (inherits(model, "lavaan")) {
    # hm, a lavaan model; let's try to extract the parameter table
    # and see what happens
    flat.model <- parTable(model)
  } else if (is.list(model)) {
    # a list! perhaps a full parameter table, or an initial flat model,
    # or something else...

	# 1. flat.model already (output of lavParseModelString)?
	if (!is.null(model$lhs) && !is.null(model$op) &&
	    !is.null(model$rhs) && !is.null(model$mod.idx) &&
		!is.null(attr(model, "modifiers"))) {
	  flat.model <- model
    }

    # look for the bare minimum columns: lhs - op - rhs
    else if (!is.null(model$lhs) && !is.null(model$op) &&
      !is.null(model$rhs) && !is.null(model$free)) {
      # ok, we have something that looks like a parameter table
      flat.model <- model

      # fix semTools issue here? for auxiliary() which does not use
      # block column yet
      if (!is.null(flat.model$block)) {
        nn <- length(flat.model$lhs)
        if (length(flat.model$block) != nn) {
          flat.model$block <- flat.model$group
        }
        if (any(is.na(flat.model$block))) {
          flat.model$block <- flat.model$group
        }
      } else if (!is.null(flat.model$group)) {
        flat.model$block <- flat.model$group
      }
    } else {
      bare.minimum <- c("lhs", "op", "rhs", "free")
      missing.idx <- is.na(match(bare.minimum, names(model)))
      lav_msg_stop(
        gettextf("model is a list, but not a parameterTable?
                 missing column(s) in parameter table: [%s]",
                  lav_msg_view(bare.minimum[missing.idx], "none")))
    }
  } else {
    lav_msg_stop(gettext("model is NULL or not a valid type for it!"))
  }

  # Ok, we got a flattened model; usually this a flat.model object, but it
  # could also be an already lavaanified parTable, or a bare-minimum list with
  # lhs/op/rhs/free elements
  flat.model
}

# this function is only needed for backwards compatibility: it falls back
# to the old (<0.6-20) way of handling composites (defined by the '<~' operator)
# we do this by substituting the '<~' operator by '~', and by creating
# phantom latent variables for the LHS, and setting the residual variance
# to zero
#
# For example: "f <~ 1*income + occup + educ" is replaced by:
# "f =~ 0; f ~~ 0*f; f ~ 1*income + occup + educ"
#
lav_lavaan_step01_ovnames_composites <- function(flat.model = NULL) {  # nolint

  # get composite idx
  c.idx <- which(flat.model$op == "<~")
  if (length(c.idx) == 0L) {
    return(flat.model)
  }

  # flat.model info
  nel <- length(flat.model$lhs)
  flat.names <- names(flat.model)
  c.names <- unique(flat.model$lhs[c.idx])
  nc <- length(c.names)
  mod.val <- max(flat.model$mod.idx)

  # check block numbers
  max.block <- max(flat.model$block)
  if (max.block > 1L) {
    lav_msg_stop(gettext("composites = FALSE is not support when multiple blocks are supported; manually replace f <~ rhs by f =~ 0; f ~~ 0*f; f ~ rhs"))
  }

  block <- 1L

  # replace '<~' by '~'
  flat.model$op[c.idx] <- "~"

  # add phantom latent variables
  flat.model$lhs     <- c(flat.model$lhs, c.names)
  flat.model$op      <- c(flat.model$op,  rep("=~", nc))
  flat.model$rhs     <- c(flat.model$rhs, c.names)
  flat.model$fixed   <- c(flat.model$fixed, rep("", nc))
  flat.model$mod.idx <- c(flat.model$mod.idx, rep(0L, nc))
  flat.model$block   <- c(flat.model$block, rep(block, nc))

  # fix residual variances
  flat.model$lhs     <- c(flat.model$lhs, c.names)
  flat.model$op      <- c(flat.model$op,  rep("~~", nc))
  flat.model$rhs     <- c(flat.model$rhs, c.names)
  flat.model$fixed   <- c(flat.model$fixed, rep("0", nc)) # just for show
  flat.model$mod.idx <- c(flat.model$mod.idx, mod.val + seq_len(nc))
  flat.model$block   <- c(flat.model$block, rep(block, nc))

  # extend the 'other' columns
  other <- flat.names[!flat.names %in% c("lhs", "op", "rhs",
                                         "fixed", "mod.idx", "block")]
  for (o in other) {
    if (is.character(flat.model[[o]])) {
      flat.model[[o]] <- c(flat.model[[o]], rep("", nc*2))
    } else if(is.integer(flat.model[[o]])) {
      flat.model[[o]] <- c(flat.model[[o]], rep(0L, nc*2))
    } else {
      flat.model[[o]] <- c(flat.model[[o]], rep(as.numeric(NA), nc*2))
    }
  }

  # add fixed values to the modifier attribute
  attr(flat.model, "modifiers") <- c(attr(flat.model, "modifiers"),
                                     rep(list(list(fixed = 0)), nc))

  flat.model
}

lav_lavaan_step01_ovnames_ovorder <- function(flat.model = NULL,       # nolint
                                              ov.order   = "model",
                                              data       = NULL,
                                              sample.cov = NULL,
                                              slotData   = NULL) {     # nolint
  # set ov.order in lowercase, check if it is "data" or "model",
  #  if not *** error ***
  # if ov.order == "data"
  #   try adapt flat.model via lav_partable_ov_from_data
  #   (** warning ** if this fails)

  # new in 0.6-14
  # if ov.order = "data", it would seem we need to intervene here;
  # ldw 1/3/2024:
  # we do this by adding an attribute "ovda" to flat.model and partable
  ov.order <- tolower(ov.order)
  if (ov.order == "data") {
    flat.model.orig <- flat.model
    try(
      flat.model <- lav_partable_ov_from_data(flat.model,
        data = data,
        sample.cov = sample.cov,
        slotData = slotData
      ),
      silent = TRUE
    )
    if (inherits(flat.model, "try-error")) {
      lav_msg_warn(gettext("ov.order = \"data\" setting failed;
                           switching back to ov.order = \"model\""))
      flat.model <- flat.model.orig
    }
  } else if (ov.order != "model") {
    lav_msg_stop(gettext(
      "ov.order= argument should be \"model\" (default) or \"data\""))
  }

  flat.model
}

lav_lavaan_step01_ovnames_group <- function(flat.model = NULL,        # nolint
                                            ngroups    = 1L) {
  # if "group :" appears in flat.model
  #   tmp.group.values: set of names in corresponding right hand sides
  #   copy flat.model without attributes and call lav_model_partable,
  #     store result in tmp.lav
  #   extract ov.names, ov.names.y, ov.names.x, lv.names from tmp.lav
  #     via lav_partable_vnames
  # else
  #   if flat.model$group not NULL and more then 1 group.value
  #     extract group.values via lav_partable_group_values
  #     extract, for each group.value,
  #       ov.names, ov.names.y, ov.names.x, lv.names from flat.model
  #       via lav_partable_vnames
  #   else
  #     extract ov.names, ov.names.y, ov.names.x, lv.names from flat.model
  #     via lav_partable_vnames
  #
  #     TODO: call lav_partable_vnames only ones and not for each type

  flat.model.2 <- NULL
  tmp.lav <- NULL
  group.values <- NULL
  ov.names  <- character(0L)
  if (any(flat.model$op == ":" & tolower(flat.model$lhs) == "group")) {
    # here, we only need to figure out:
    # - ngroups
    # - ov's per group
    #
    # - FIXME: we need a more efficient way, avoiding
    #          lav_model_partable/lav_partable_vnames
    #
    group.idx <- which(flat.model$op == ":" &
                       tolower(flat.model$lhs) == "group")
    # replace by 'group' (in case we got 'Group'):
    flat.model$lhs[group.idx] <- "group"
    tmp.group.values <- unique(flat.model$rhs[group.idx])
    tmp.ngroups <- length(tmp.group.values)

    flat.model.2 <- flat.model
    attr(flat.model.2, "modifiers") <- NULL
    attr(flat.model.2, "constraints") <- NULL
    tmp.lav <- lav_model_partable(flat.model.2, ngroups = tmp.ngroups, warn = FALSE)
    ov.names <- ov.names.y <- ov.names.x <- lv.names <- vector("list",
      length = tmp.ngroups
    )
    attr(tmp.lav, "vnames") <- lav_partable_vnames(tmp.lav, type = "*")
    for (g in seq_len(tmp.ngroups)) {
      ov.names[[g]] <- unique(unlist(lav_partable_vnames(tmp.lav,
        type = "ov", group = tmp.group.values[g]
      )))
      ov.names.y[[g]] <- unique(unlist(lav_partable_vnames(tmp.lav,
        type = "ov.nox", group = tmp.group.values[g]
      )))
      ov.names.x[[g]] <- unique(unlist(lav_partable_vnames(tmp.lav,
        type = "ov.x", group = tmp.group.values[g]
      )))
      lv.names[[g]] <- unique(unlist(lav_partable_vnames(tmp.lav,
        type = "lv", group = tmp.group.values[g]
      )))
    }
  } else if (!is.null(flat.model$group)) {
    # user-provided full partable with group column!
    attr(flat.model, "vnames") <- lav_partable_vnames(flat.model, type = "*")
    ngroups <- lav_partable_ngroups(flat.model)
    if (ngroups > 1L) {
      group.values <- lav_partable_group_values(flat.model)
      ov.names <- ov.names.y <- ov.names.x <- lv.names <- vector("list",
        length = ngroups
      )
      for (g in seq_len(ngroups)) {
        # collapsed over levels (if any)
        ov.names[[g]] <- unique(unlist(lav_partable_vnames(flat.model,
          type = "ov", group = group.values[g]
        )))
        ov.names.y[[g]] <- unique(unlist(lav_partable_vnames(flat.model,
          type = "ov.nox", group = group.values[g]
        )))
        ov.names.x[[g]] <- unique(unlist(lav_partable_vnames(flat.model,
          type = "ov.x", group = group.values[g]
        )))
        lv.names[[g]] <- unique(unlist(lav_partable_vnames(flat.model,
          type = "lv", group = group.values[g]
        )))
      }
    } else {
      ov.names   <- lav_partable_vnames(flat.model, type = "ov")
      ov.names.y <- lav_partable_vnames(flat.model, type = "ov.nox")
      ov.names.x <- lav_partable_vnames(flat.model, type = "ov.x")
      lv.names   <- lav_partable_vnames(flat.model, type = "lv")
    }
  } else {
    # collapse over levels (if any)
    attr(flat.model, "vnames") <- lav_partable_vnames(flat.model, type = "*")
    ov.names   <- unique(unlist(lav_partable_vnames(flat.model, type = "ov")))
    ov.names.y <- unique(unlist(lav_partable_vnames(flat.model,
      type = "ov.nox")))
    ov.names.x <- unique(unlist(lav_partable_vnames(flat.model, type = "ov.x")))
    lv.names   <- unique(unlist(lav_partable_vnames(flat.model, type = "lv")))
  }

  # sanity check (new in 0.6-8): do we have any ov.names?
  # detect early
  if (length(unlist(ov.names)) == 0L) {
    lav_msg_stop(
      gettext("ov.names is empty: model does not refer to any observed
              variables; check your syntax."))
  }

  list(
    flat.model   = flat.model,
    ov.names     = ov.names,
    ov.names.x   = ov.names.x,
    ov.names.y   = ov.names.y,
    lv.names     = lv.names,
    group.values = group.values,
    ngroups      = ngroups
  )
}

lav_lavaan_step01_ovnames_checklv <- function(                    # nolint
    lv.names    = character(0L),
    ov.names    = character(0L),
    data        = NULL,
    sample.cov  = NULL,
    dotdotdot   = NULL,
    slotOptions = NULL) {                                         # nolint

  # latent variable names should not appear in the subset of the data
  #   that is formed by merging ov+lv names --> **warning**
  # latent interactions are not supported ---> *** error ***

  if (is.null(data) && is.null(sample.cov)) {
    return(invisible(NULL))
  }

  # handle for lv.names that are also observed variables (new in 0.6-6)
  lv.lv.names <- unique(unlist(lv.names))
  ov.ov.names <- unique(unlist(ov.names))
  if (length(lv.lv.names) > 0L) {

    # get data-based variable names
    data_names <- character(0L)
    if (!is.null(data)) {
      data_names <- names(data)
    } else if (!is.null(sample.cov)) {
      data_names <- rownames(sample.cov)
    }

    # create subset of variable names, based on the model
    model_names <- unique(c(ov.ov.names, lv.lv.names))
    subset_names <- data_names[data_names %in% model_names]
    bad.idx <- which(lv.lv.names %in% subset_names)

    if (length(bad.idx) > 0L) {
      if (!is.null(dotdotdot$check.lv.names) &&
        !dotdotdot$check.lv.names) {
        # ignore it, user switched this check off -- new in 0.6-7
      } else {
        lav_msg_warn(gettextf(
          "Some latent variable names collide with observed variable names in
           the dataset: %s. Please provide alternative names for the latent
           variables, or switch off this check using check.lv.names = FALSE",
           paste(lv.lv.names[bad.idx], collapse = " "))
        )
      }
    }
  }

  # sanity check: we do not support latent interaction yet (using the :)
  lv.int.idx <- which(grepl(":", lv.lv.names))
  if (length(lv.int.idx) > 0L) {
    if (!is.null(dotdotdot$check.lv.interaction) &&
      !dotdotdot$check.lv.interaction) {
      # ignore, user (or sam) switched this check off - new in 0.6-16
    } else if (!is.null(slotOptions) && !slotOptions$check.lv.interaction) {
      # ignore
    } else {
      lav_msg_stop(gettextf(
        "Interaction terms involving latent variables (%s) are not supported.
         Either use the sam() function, or consider using the modsem package.",
         lv.lv.names[lv.int.idx[1]]))
    }
  }

  invisible(NULL)
}

lav_lavaan_step01_ovnames_namesl <- function(data         = NULL,  # nolint
                                             cluster      = NULL,
                                             flat.model   = NULL,
                                             group.values = NULL,
                                             ngroups      = 1L) {
  # if "level :" appears in flat.model
  #   if data not NULL, cluster must not be NULL, if it is: *** error ***
  #   compute tmp.group.values and tmp.level.values from flat.model
  #   there should be at least 2 levels, if not *** error ***
  #   copy flat.model without attributes and lav_model_partable -> tmp.lav
  #   check at least 2 levels for tmp.lav, if not *** error ***
  #   compute ov.names.l per group and per level (via lav_partable_vnames
  #     on tmp.lav)
  # else
  #   if lav_partable_nlevels(flat.model) > 0
  #   if data not NULL, cluster must not be NULL, if it is: *** error ***
  #     compute ov.names.l per group and per level (via lav_partable_vnames
  #     on flat.model)
  #   else
  #     there are no levels (ov.names.l = list())

  # handle ov.names.l
  if (any(flat.model$op == ":" & tolower(flat.model$lhs) == "level")) {
    # check for cluster argument
    if (!is.null(data) && is.null(cluster)) {
      lav_msg_stop(gettext("cluster argument is missing."))
    }

    # here, we only need to figure out:
    # - nlevels
    # - ov's per level
    # - FIXME: we need a more efficient way, avoiding lav_model_partable/vnames

    group.idx <- which(flat.model$op == ":" & flat.model$lhs == "group")
    tmp.group.values <- unique(flat.model$rhs[group.idx])
    tmp.ngroups <- max(c(length(tmp.group.values), 1))

    level.idx <- which(flat.model$op == ":" &
                       tolower(flat.model$lhs) == "level")
    # replace by "level" (in case we got 'Level')
    flat.model$lhs[level.idx] <- "level"
    tmp.level.values <- unique(flat.model$rhs[level.idx])
    tmp.nlevels <- length(tmp.level.values)

    # we need at least 2 levels (for now)
    if (tmp.nlevels < 2L) {
      lav_msg_stop(
        gettext("when data is clustered, you must specify a model
                for each level in the model syntax (for now);
                see example(Demo.twolevel)")
      )
    }

    flat.model.2 <- flat.model
    attr(flat.model.2, "modifiers") <- NULL
    attr(flat.model.2, "constraints") <- NULL
    tmp.lav <- lav_model_partable(flat.model.2, ngroups = tmp.ngroups, warn = FALSE)
    # check for empty levels
    if (max(tmp.lav$level) < 2L) {
      lav_msg_stop(
        gettext("at least one level has no model syntax;
                you must specify a model for each level in the model syntax;
                see example(Demo.twolevel)")
      )
    }
    ov.names.l <- vector("list", length = tmp.ngroups) # per group

    for (g in seq_len(tmp.ngroups)) {
      ov.names.l[[g]] <- vector("list", length = tmp.nlevels)
      for (l in seq_len(tmp.nlevels)) {
        if (tmp.ngroups > 1L) {
          ov.names.l[[g]][[l]] <-
            unique(unlist(lav_partable_vnames(tmp.lav,
              type = "ov",
              group = tmp.group.values[g],
              level = tmp.level.values[l]
            )))
        } else {
          ov.names.l[[g]][[l]] <-
            unique(unlist(lav_partable_vnames(tmp.lav,
              type = "ov",
              level = tmp.level.values[l]
            )))
        }
      } # levels
    } # groups
  } else {
    # perhaps model is already a parameter table
    nlevels <- lav_partable_nlevels(flat.model)
    if (nlevels > 1L) {
      # check for cluster argument (only if we have data)
      if (!is.null(data) && is.null(cluster)) {
        lav_msg_stop(gettext("cluster argument is missing."))
      }

      ngroups <- lav_partable_ngroups(flat.model)
      group.values <- lav_partable_group_values(flat.model)
      ov.names.l <- vector("list", length = ngroups)
      for (g in 1:ngroups) {
        # note: lav_object_vnames() will return a list if any level:
        ov.names.l[[g]] <- lav_object_vnames(flat.model, "ov", group = group.values[g])
      }
    } else {
      # no level: in model syntax
      ov.names.l <- list()
    }
  }

  list(
    flat.model = flat.model,
    ov.names.l = ov.names.l
  )
}

lav_lavaan_step01_ovnames_ordered <- function(ordered    = NULL,  # nolint
                                              flat.model = NULL,
                                              data       = NULL) {
  # interpretation and check ordered parameter, modify if needed

  # sanity check ordered argument (just in case, add lhs variables names)
  if (!is.null(ordered)) { # new in 0.6-4
    if (is.logical(ordered) && ordered) { # ordered = TRUE
      # assume the user means: ordered = names(Data)
      ordered <- lav_object_vnames(flat.model, "ov.nox") # new in 0.6-6: changed from ov
    } else if (is.logical(ordered) && !ordered) {
      ordered <- character(0L)
    } else if (!is.character(ordered)) {
      lav_msg_stop(gettext("ordered argument must be a character vector"))
    } else if (length(ordered) == 1L && nchar(ordered) == 0L) {
      ordered <- character(0L)
    } else {
      # check if all names in "ordered" occur in the dataset?
      if (!is.null(data)) {
        if (inherits(data, "data.frame")) {
          data_names <- names(data)
        } else if (inherits(data, "matrix")) {
          data_names <- colnames(data)
        }
        missing.idx <- which(!ordered %in% data_names)
        if (length(missing.idx) > 0L) { # FIXme: warn = FALSE has no eff
          lav_msg_warn(gettextf(
            "ordered variable(s): %s could not be found
            in the data and will be ignored",
             paste(ordered[missing.idx], collapse = " ")))
        }
      }
    }
  }

  # add the variable names that were treated as ordinal
  # in the model syntax
  ordered <- unique(c(ordered, lav_object_vnames(flat.model, "ov.ord")))

  ordered
}

# lavaan parameter table
#
# initial version: YR 22/05/2009
#  major revision: YR 02/11/2010: - FLATTEN the model syntax and turn it into a
#                                   data.frame, with a "modifiers" attribute
#                                 - add default elements here
#                                 - check for duplicate elements
#                                 - allow for every possible model...
#                                 - since 0.4-5
#                                 - the end result is a full description of
#                                   a model (but no matrix representation)
# - 14 Jan 2014: merge 02lavaanUser.R with lav_partable.R
#                move syntax-based code to lav_syntax.R
# - 26 April 2016: handle multiple 'blocks' (levels, classes, groups, ...)
# - 24 March 2019: handle efa sets
# - 23 May   2020: support for random slopes

lav_model_partable  <- function(
                                model = NULL,
                                meanstructure = FALSE,
                                int.ov.free = FALSE,
                                int.lv.free = FALSE,
                                marker.int.zero = FALSE,
                                orthogonal = FALSE,
                                orthogonal.y = FALSE,
                                orthogonal.x = FALSE,
                                orthogonal.efa = FALSE,
                                std.lv = FALSE,
                                correlation = FALSE,
                                composites = TRUE,
                                effect.coding = "",
                                conditional.x = FALSE,
                                fixed.x = FALSE,
                                parameterization = "delta",
                                constraints = NULL,
                                ceq.simple = FALSE,
                                auto = FALSE,
                                model.type = "sem",
                                auto.fix.first = FALSE,
                                auto.fix.single = FALSE,
                                auto.var = FALSE,
                                auto.cov.lv.x = FALSE,
                                auto.cov.y = FALSE,
                                auto.th = FALSE,
                                auto.delta = FALSE,
                                auto.efa = FALSE,
                                varTable = NULL, # nolint
                                ngroups = 1L,
                                nthresholds = NULL,
                                group.equal = NULL,
                                group.partial = NULL,
                                group.w.free = FALSE,
                                debug = FALSE,
                                warn = TRUE,
                                as.data.frame. = TRUE) { # nolint
  if (!missing(debug)) {
    current.debug <- lav_debug()
    if (lav_debug(debug))
      on.exit(lav_debug(current.debug), TRUE)
  }
  if (!missing(warn)) {
    current.warn <- lav_warn()
    if (lav_warn(warn))
      on.exit(lav_warn(current.warn), TRUE)
  }
  # check if model is already flat or a full parameter table
  if (is.list(model) && !is.null(model$lhs)) {
    if (is.null(model$mod.idx)) {
      lav_msg_warn(gettext("input already looks like a parameter table"))
      return(lav_partable_set_cache(model))
    } else {
      flat <- model
    }
  } else {
    # parse the model syntax and flatten the user-specified model
    # return a data.frame, where each line is a model element (rhs, op, lhs)
    flat <- lavParseModelString(
      model.syntax = model, debug = FALSE
    )
  }
  # user-specified *modifiers* are returned as an attribute
  tmp.mod <- attr(flat, "modifiers")
  attr(flat, "modifiers") <- NULL
  # user-specified *constraints* are returned as an attribute
  tmp.con <- attr(flat, "constraints")
  attr(flat, "constraints") <- NULL

  # ov.names.data?
  ov.names.data <- attr(flat, "ovda")

  # extra constraints?
  if (!is.null(constraints) && any(nchar(constraints) > 0L)) {
    flat2 <- lavParseModelString(model.syntax = constraints, warn = lav_warn())
    con2 <- attr(flat2, "constraints")
    rm(flat2)
    tmp.con <- c(tmp.con, con2)
  }
  if (length(tmp.con) > 0L) {
    # add 'user' column
    tmp.con <- lapply(tmp.con, function(x) {
      x$user <- 1L
      x
    })
    # any explicit (in)equality constraints? (ignoring := definitions)
    tmp.con.nondef.flag <- (sum(sapply(tmp.con, "[[", "op")
    %in% c("==", "<", ">")) > 0L)
    # any explicit equality constraints?
    tmp.con.eq.flag <- (sum(sapply(tmp.con, "[[", "op") == "==") > 0L)
    if (tmp.con.nondef.flag) {
      ceq.simple <- FALSE
    }
  }

  if (lav_debug()) {
    cat("[lavaan DEBUG]: flat (flattened user model):\n")
    print(flat)
    cat("[lavaan DEBUG]: tmp.mod (modifiers):\n")
    print(str(tmp.mod))
    cat("[lavaan DEBUG]: tmp.con (constraints):\n")
    print(str(tmp.con))
  }

  # bogus varTable? (if data.type == "none")
  if (!is.null(varTable)) {
    if (!is.list(varTable) || is.null(varTable$name)) {
      lav_msg_stop(gettext(
        "varTable is not a list or does not contain variable names."))
    }
    if (all(varTable$nobs == 0)) {
      varTable <- NULL # nolint
    }
  }

  # check for wrongly specified variances/covariances/intercepts
  # of exogenous variables in model syntax (if fixed.x=TRUE)
  if (fixed.x && lav_warn()) { # we ignore the groups here!
    # we only call this function for the warning message
    tmp <- lav_partable_vnames(flat, "ov.x", force.warn = TRUE)
    rm(tmp)
  }

  # check if group.equal is non-empty, but ngroups = 1L
  # fixme: triggers this if mimic="Mplus"!
  # if(ngroups == 1L && length(group.equal) > 0L) {
  #    warning("lavaan WARNING: group.equal= argument",
  #    " has no effect if no groups are specified.")
  # }

  # auto=TRUE?
  if (auto) { # mimic sem/cfa auto behavior
    if (model.type == "sem") {
      int.ov.free <- TRUE
      int.lv.free <- FALSE
      auto.fix.first <- !std.lv
      auto.fix.single <- TRUE
      auto.var <- TRUE
      auto.cov.lv.x <- TRUE
      auto.cov.y <- TRUE
      auto.th <- TRUE
      auto.delta <- TRUE
      auto.efa <- TRUE
    } else if (model.type == "growth") {
      model.type <- "growth"
      int.ov.free <- FALSE
      int.lv.free <- TRUE
      auto.fix.first <- !std.lv
      auto.fix.single <- TRUE
      auto.var <- TRUE
      auto.cov.lv.x <- TRUE
      auto.cov.y <- TRUE
      auto.th <- TRUE
      auto.delta <- TRUE
      auto.efa <- TRUE
    }
  }

  # check for meanstructure
  if (any(flat$op == "~1")) {
    meanstructure <- TRUE
  }

  # check for block identifiers in the syntax (op = ":")
  n.block.flat <- length(which(flat$op == ":"))
  # this is NOT the number of blocks (eg group 1: level 1: -> 1 block)

  # for each non-empty `block' in n.block.flat, produce a USER
  if (n.block.flat > 0L) {
    # make sure flat is a data.frame
    flat <- as.data.frame(flat, stringsAsFactors = FALSE)

    # what are the block lhs labels?
    blocks.lhs.all <- tolower(flat$lhs[flat$op == ":"])
    tmp.block.lhs <- unique(blocks.lhs.all)

    # if we have group and level, check that group comes first!
    if ("group" %in% tmp.block.lhs && "level" %in% tmp.block.lhs) {
      group.idx <- which(tmp.block.lhs == "group")
      level.idx <- which(tmp.block.lhs == "level")
      if (group.idx > level.idx) {
        lav_msg_stop(gettext(
          "levels must be nested within groups (not the other way around)."))
      }
    }

    # block op == ":" indices
    block.op.idx <- which(flat$op == ":")

    # check for wrong spelled 'group' lhs
    if (length(grep("group", tmp.block.lhs)) > 1L) {
      lav_msg_warn(gettext("ambiguous block identifiers for group:"),
        lav_msg_view(tmp.block.lhs[grep("group", tmp.block.lhs)], "none"))
    }

    # no empty :rhs fields allowed!
    if (any(nchar(flat$rhs[block.op.idx]) == 0L)) {
      empty.idx <- nchar(flat$rhs[block.op.idx]) == 0L
      txt <- paste(flat$lhs[block.op.idx][empty.idx], ":")
      lav_msg_stop(gettext(
        "syntax contains block identifiers with missing numbers/labels: "), txt)
    }

    # check for ngroups (ngroups is based on the data!)
    if ("group" %in% tmp.block.lhs) {
      # how many group blocks?
      group.block.idx <- flat$op == ":" & flat$lhs == "group"
      n.group.flat <- length(unique(flat$rhs[group.block.idx]))

      if (n.group.flat > 0L && n.group.flat != ngroups) {
        lav_msg_stop(gettextf(
          "syntax defines %1$s groups; data (or argument ngroups)
          suggests %2$s groups", n.group.flat, ngroups))
      }
    }

    # figure out how many 'blocks' we have, and store indices/block.labels
    tmp.block.rhs <- rep("0", length(tmp.block.lhs))
    block.id <- 0L
    block.info <- vector("list", length = n.block.flat) # too large
    block.op.idx1 <- c(block.op.idx, nrow(flat) + 1L) # add addition row
    for (block.op in seq_len(n.block.flat)) {
      # fill block.rhs value(s)
      block.lhs <- flat$lhs[block.op.idx1[block.op]]
      block.rhs <- flat$rhs[block.op.idx1[block.op]]
      tmp.block.rhs[which(block.lhs == tmp.block.lhs)] <- block.rhs

      # another block identifier?
      if (block.op.idx1[block.op + 1L] - block.op.idx1[block.op] == 1L) {
        next
      }

      # we have a 'block'
      block.id <- block.id + 1L

      # select flat rows for this block
      tmp.idx <- seq.int(
        block.op.idx1[block.op] + 1L,
        block.op.idx1[block.op + 1L] - 1L
      )

      # store info in block.info
      block.info[[block.id]] <- list(
        lhs = tmp.block.lhs, # always the same
        rhs = tmp.block.rhs, # for this block
        idx = tmp.idx
      )
    }
    block.info <- block.info[seq_len(block.id)]

    # new in 0.6-12
    # check for blocks with the same block.rhs combination
    # (perhaps added later?)
    # - merge the indices
    # - remove the duplicated blocks
    block.labels <- sapply(lapply(block.info, "[[", "rhs"),
      paste,
      collapse = "."
    )
    nblocks <- length(unique(block.labels))
    if (nblocks < length(block.labels)) {
      # it would appear we have duplicated block.labels -> merge
      dup.idx <- which(duplicated(block.labels))
      for (i in seq_along(dup.idx)) {
        this.dup.idx <- dup.idx[i]
        orig.idx <- which(block.labels == block.labels[this.dup.idx])[1]
        block.info[[orig.idx]]$idx <- c(
          block.info[[orig.idx]]$idx,
          block.info[[this.dup.idx]]$idx
        )
      }
      block.info <- block.info[-dup.idx]
    }

    # split the flat data.frame per `block', create tmp.list
    # for each `block', and rbind them together, adding block columns
    for (block in seq_len(nblocks)) {
      tmp.block.rhs <- block.info[[block]]$rhs
      block.lhs <- block.info[[block]]$lhs[length(tmp.block.lhs)] # last one
      block.idx <- block.info[[block]]$idx

      flat.block <- flat[block.idx, ]
      # rm 'block' column (if any) in flat.block
      flat.block$block <- NULL

      # new in 0.6-7: check for random slopes, add them here
      if (block.lhs == "level" &&
        block > 1L && # FIXME: multigroup, multilevel
        !is.null(flat$rv) &&
        any(nchar(flat$rv) > 0L)) {
        lv.names.rv <- unique(flat$rv[nchar(flat$rv) > 0L])
        for (i in seq_along(lv.names.rv)) {
          # add phantom latent variable
          tmp <- flat.block[1, ]
          tmp$lhs <- lv.names.rv[i]
          tmp$op <- "=~"
          tmp$rhs <- lv.names.rv[i]
          tmp$mod.idx <- max(flat$mod.idx) + i
          tmp$fixed <- "0"
          tmp$start <- ""
          tmp$lower <- ""
          tmp$upper <- ""
          tmp$label <- ""
          tmp$prior <- ""
          tmp$efa <- ""
          tmp$rv <- lv.names.rv[i]
          flat.block <- rbind(flat.block, tmp, deparse.level = 0L)
          tmp.mod <- c(tmp.mod, list(list(fixed = 0)))
        }
      }

      # new in 0.6-8: if multilevel, use 'global' ov.names.x
      if (fixed.x && block.lhs == "level") {
        tmp.ov.names.x <- lav_partable_vnames(flat, "ov.x") # global
        ov.names.x.block <- lav_partable_vnames(flat.block, "ov.x")
        if (length(ov.names.x.block) > 0L) {
          idx <- which(!ov.names.x.block %in% tmp.ov.names.x)
          if (length(idx) > 0L) {
            # warn!
            lav_msg_warn(gettextf(
              "the variable(s) [%s] are exogenous at one level, but endogenous
              at another level. These variables will be treated as endogenous,
              and their variances/intercepts will be freely estimated.
              To remove this warning, use fixed.x = FALSE.",
              lav_msg_view(ov.names.x.block[idx], "none")))
            ov.names.x.block <- ov.names.x.block[-idx]
          }
        }
      } else {
        ov.names.x.block <- NULL
      }

      # new in 0.6-12: if multilevel and conditional.x, make sure
      # that 'splitted' exogenous covariates become 'y' variables
      if (conditional.x && block.lhs == "level") {
        if (ngroups == 1L) {
          other.block.names <- lav_partable_vnames(flat, "ov",
            block = seq_len(nblocks)[-block]
          )
        } else {
          # TEST ME
          this.group <- ceiling(block / nlevels)
          blocks.within.group <- (this.group - 1L) * nlevels + seq_len(nlevels)
          other.block.names <- lav_partable_vnames(flat, "ov",
            block = blocks.within.group[-block]
          )
        }
        ov.names.x.block <- lav_partable_vnames(flat.block, "ov.x")
        if (length(ov.names.x.block) > 0L) {
          idx <- which(ov.names.x.block %in% other.block.names)
          if (length(idx) > 0L) {
            ov.names.x.block <- ov.names.x.block[-idx]
          }
        }
      } else {
        ov.names.x.block <- NULL
      }

      list.block <- lav_partable_flat(flat.block,
        blocks = tmp.block.lhs,
        block.id = block,
        meanstructure = meanstructure,
        int.ov.free = int.ov.free, int.lv.free = int.lv.free,
        orthogonal = orthogonal, orthogonal.y = orthogonal.y,
        orthogonal.x = orthogonal.x, orthogonal.efa = orthogonal.efa,
        std.lv = std.lv, correlation = correlation, composites = composites,
        conditional.x = conditional.x, fixed.x = fixed.x,
        parameterization = parameterization,
        auto.fix.first = auto.fix.first,
        auto.fix.single = auto.fix.single,
        auto.var = auto.var, auto.cov.lv.x = auto.cov.lv.x,
        auto.cov.y = auto.cov.y, auto.th = auto.th,
        auto.delta = auto.delta, auto.efa = auto.efa,
        varTable = varTable, group.equal = NULL,
        group.w.free = group.w.free, ngroups = 1L,
        nthresholds = nthresholds,
        ov.names.x.block = ov.names.x.block
      )
      list.block <- as.data.frame(list.block, stringsAsFactors = FALSE)

      # add block columns with current values in block.rhs
      for (b in seq_len(length(tmp.block.lhs))) {
        block.lhs <- tmp.block.lhs[b]
        block.rhs <- tmp.block.rhs[b]
        list.block[block.lhs] <- rep(block.rhs, length(list.block$lhs))
      }

      if (!exists("tmp.list")) {
        tmp.list <- list.block
      } else {
        list.block$id <- list.block$id + max(tmp.list$id)
        tmp.list <- rbind(tmp.list, list.block)
      }
    }
    tmp.list <- as.list(tmp.list)

    # convert block columns to integers if possible
    for (b in seq_len(length(tmp.block.lhs))) {
      block.lhs <- tmp.block.lhs[b]
      block.rhs <- tmp.block.rhs[b]
      tmp <- try(scan(
        text = tmp.list[[block.lhs]], what = integer(),
        quiet = TRUE
      ), silent = TRUE)
      if (inherits(tmp, "integer")) {
        tmp.list[[block.lhs]] <- tmp
      }
    }
  } else {
    tmp.list <- lav_partable_flat(flat,
      blocks = "group",
      meanstructure = meanstructure,
      int.ov.free = int.ov.free, int.lv.free = int.lv.free,
      orthogonal = orthogonal, orthogonal.y = orthogonal.y,
      orthogonal.x = orthogonal.x, orthogonal.efa = orthogonal.efa,
      std.lv = std.lv, correlation = correlation, composites = composites,
      conditional.x = conditional.x, fixed.x = fixed.x,
      parameterization = parameterization,
      auto.fix.first = auto.fix.first, auto.fix.single = auto.fix.single,
      auto.var = auto.var, auto.cov.lv.x = auto.cov.lv.x,
      auto.cov.y = auto.cov.y, auto.th = auto.th,
      auto.delta = auto.delta, auto.efa = auto.efa,
      varTable = varTable, group.equal = group.equal,
      group.w.free = group.w.free,
      ngroups = ngroups, nthresholds = nthresholds
    )
  }
  if (lav_debug()) {
    cat("[lavaan DEBUG]: parameter tmp.list without MODIFIERS:\n")
    print(as.data.frame(tmp.list, stringsAsFactors = FALSE))
  }

  # check for auto-regressions
  auto.reg.idx <- which(tmp.list$op == "~" &
                        tmp.list$lhs == tmp.list$rhs)

  # check ordinal variables
  categorical <- FALSE
  ov.ord <- lav_object_vnames(tmp.list, "ov.ord")
  if (length(ov.ord) > 0L) {
    categorical <- TRUE
    ord.var.idx <- which(tmp.list$op == "~~" &
                         tmp.list$lhs == tmp.list$rhs &
                         tmp.list$lhs %in% ov.ord &
                         tmp.list$user == 1L)
    if (parameterization == "delta" && length(ord.var.idx) > 0L) {
      lav_msg_warn(gettextf("variances of ordered variables are ignored when
      parameterization = \"delta\"; please remove them from the model syntax
      or use parameterization = \"theta\"; variables involved are: %s",
      paste(tmp.list$lhs[ord.var.idx], collapse = " ")))
      # force them to be nonfree and set ustart to 1 (new in 0.6-20)
      # later, after we have processes the modifiers
    }
  } # ov.ord

  # handle multilevel-specific constraints
  multilevel <- FALSE
  nlevels <- 1L
  if (!is.null(tmp.list$level)) {
    nlevels <- lav_partable_nlevels(tmp.list)
    if (nlevels > 1L) {
      multilevel <- TRUE
    }
  }
  if (multilevel && any(tmp.list$op == "~1")) {
    # fix ov intercepts for all within ov that also appear at level 2
    # FIXME: not tested with > 2 levels
    ov.names <- lav_partable_vnames(tmp.list, "ov") ## all names
    level.values <- lav_partable_level_values(tmp.list)
    other.names <- tmp.list$lhs[tmp.list$op == "~1" &
      tmp.list$level %in% level.values[-1L] &
      tmp.list$lhs %in% ov.names]
    fix.names.idx <- which(tmp.list$op == "~1" &
      tmp.list$level %in% level.values[1L] &
      tmp.list$lhs %in% other.names)
    if (length(fix.names.idx) > 0L) {
      tmp.list$free[fix.names.idx] <- 0L
      tmp.list$ustart[fix.names.idx] <- 0
    }
  }
  if (multilevel && any(tmp.list$op == "|")) {
    # fix ALL thresholds at level 1
    level.values <- lav_partable_level_values(tmp.list)
    th.idx <- which(tmp.list$op == "|" &
      tmp.list$level %in% level.values[1L])
    tmp.list$free[th.idx] <- 0L
    tmp.list$ustart[th.idx] <- 0

    # fix ALL scaling parmaters at higher levels
    scale.idx <- which(tmp.list$op == "~*~" &
      tmp.list$level %in% level.values[-1L])
    tmp.list$free[scale.idx] <- 0L
    tmp.list$ustart[scale.idx] <- 1
  }

  # apply user-specified modifiers
  warn.about.single.label <- FALSE
  if (length(tmp.mod)) {
    for (el in seq_along(tmp.mod)) {
      idx <- which(tmp.list$mod.idx == el) # for each group

      # 0.5-21: check if idx exists
      # perhaps the corresponding element was duplicated, and removed
      if (length(idx) == 0L) {
        next
      }

      tmp.mod.fixed <- tmp.mod[[el]]$fixed
      tmp.mod.start <- tmp.mod[[el]]$start
      tmp.mod.lower <- tmp.mod[[el]]$lower
      tmp.mod.upper <- tmp.mod[[el]]$upper
      tmp.mod.label <- tmp.mod[[el]]$label
      tmp.mod.prior <- tmp.mod[[el]]$prior
      tmp.mod.efa <- tmp.mod[[el]]$efa
      tmp.mod.rv <- tmp.mod[[el]]$rv

      # check for single argument if multiple groups
      if (ngroups > 1L && length(idx) > 1L) {
        # Ok, this is not very consistent:
        # A) here we force same behavior across groups
        if (length(tmp.mod.fixed) == 1L) {
          tmp.mod.fixed <- rep(tmp.mod.fixed, ngroups)
        }
        if (length(tmp.mod.start) == 1L) {
          tmp.mod.start <- rep(tmp.mod.start, ngroups)
        }
        if (length(tmp.mod.lower) == 1L) {
          tmp.mod.lower <- rep(tmp.mod.lower, ngroups)
        }
        if (length(tmp.mod.upper) == 1L) {
          tmp.mod.upper <- rep(tmp.mod.upper, ngroups)
        }
        if (length(tmp.mod.prior) == 1L) {
          tmp.mod.prior <- rep(tmp.mod.prior, ngroups)
        }
        if (length(tmp.mod.efa) == 1L) {
          tmp.mod.efa <- rep(tmp.mod.efa, ngroups)
        }
        if (length(tmp.mod.rv) == 1L) {
          tmp.mod.rv <- rep(tmp.mod.rv, ngroups)
        }

        # new in 0.6-7 (proposal):
        # - always recycle modifiers, including labels
        # - if ngroups > 1 AND group.label= is empty, produce a warning
        #   (as this is a break from < 0.6-6)
        if (length(tmp.mod.label) == 1L) {
          tmp.mod.label <- rep(tmp.mod.label, ngroups)
          if (is.null(group.equal) || length(group.equal) == 0L) {
            warn.about.single.label <- TRUE
          }
        }

        # < 0.6-7 code:
        # B) here we do NOT! otherwise, it would imply an equality
        #                    constraint...
        #    except if group.equal="loadings"!
        # if(length(tmp.mod.label) == 1L) {
        #    if("loadings" %in% group.equal ||
        #       "composite.loadings" %in% group.equal) {
        #        tmp.mod.label <- rep(tmp.mod.label, ngroups)
        #    } else {
        #        tmp.mod.label <- c(tmp.mod.label, rep("", (ngroups-1L)) )
        #    }
        # }
      }

      # check for wrong number of arguments if multiple groups
      nidx <- length(idx)
      if ((!is.null(tmp.mod.fixed) && nidx != length(tmp.mod.fixed)) ||
        (!is.null(tmp.mod.start) && nidx != length(tmp.mod.start)) ||
        (!is.null(tmp.mod.lower) && nidx != length(tmp.mod.lower)) ||
        (!is.null(tmp.mod.upper) && nidx != length(tmp.mod.upper)) ||
        (!is.null(tmp.mod.prior) && nidx != length(tmp.mod.prior)) ||
        (!is.null(tmp.mod.efa) && nidx != length(tmp.mod.efa)) ||
        (!is.null(tmp.mod.rv) && nidx != length(tmp.mod.rv)) ||
        (!is.null(tmp.mod.label) && nidx != length(tmp.mod.label))) {
        el.idx <- which(tmp.list$mod.idx == el)[1L]
        lav_msg_stop(gettextf(
          "wrong number of arguments in modifier (%s) of element",
          lav_msg_view(tmp.mod.label, "none")),
          tmp.list$lhs[el.idx], tmp.list$op[el.idx], tmp.list$rhs[el.idx]
        )
      }

      # apply modifiers
      if (!is.null(tmp.mod.fixed)) {
        # two options: constant or NA
        na.idx <- which(is.na(tmp.mod.fixed))
        not.na.idx <- which(!is.na(tmp.mod.fixed))

        # constant
        tmp.list$ustart[idx][not.na.idx] <- tmp.mod.fixed[not.na.idx]
        tmp.list$free[idx][not.na.idx] <- 0L

        # NA* modifier
        tmp.list$free[idx][na.idx] <- 1L # eg factor loading
        tmp.list$ustart[idx][na.idx] <- as.numeric(NA)
      }
      if (!is.null(tmp.mod.start)) {
        tmp.list$ustart[idx] <- tmp.mod.start
      }
      if (!is.null(tmp.mod.prior)) {
        # do we already have a `prior' column? if not, create one
        if (is.null(tmp.list$prior)) {
          tmp.list$prior <- character(length(tmp.list$lhs))
        }
        tmp.list$prior[idx] <- tmp.mod.prior
      }
      if (!is.null(tmp.mod.efa)) {
        # do we already have a `efa' column? if not, create one
        if (is.null(tmp.list$efa)) {
          tmp.list$efa <- character(length(tmp.list$lhs))
        }
        tmp.list$efa[idx] <- tmp.mod.efa
      }
      if (!is.null(tmp.mod.rv)) {
        # do we already have a `rv' column? if not, create one
        if (is.null(tmp.list$rv)) {
          tmp.list$rv <- character(length(tmp.list$lhs))
        }
        tmp.list$rv[idx] <- tmp.mod.rv

        tmp.list$free[idx] <- 0L
        tmp.list$ustart[idx] <- as.numeric(NA) #
      }
      if (!is.null(tmp.mod.lower)) {
        # do we already have a `lower' column? if not, create one
        if (is.null(tmp.list$lower)) {
          tmp.list$lower <- rep(-Inf, length(tmp.list$lhs))
        }
        tmp.list$lower[idx] <- as.numeric(tmp.mod.lower)
      }
      if (!is.null(tmp.mod.upper)) {
        # do we already have a `upper' column? if not, create one
        if (is.null(tmp.list$upper)) {
          tmp.list$upper <- rep(Inf, length(tmp.list$lhs))
        }
        tmp.list$upper[idx] <- as.numeric(tmp.mod.upper)
      }
      if (!is.null(tmp.mod.label)) {
        tmp.list$label[idx] <- tmp.mod.label
      }
    }
  }
  # remove mod.idx column
  tmp.list$mod.idx <- NULL

  # categorical: check for nonfree variances if parameterization = "delta"
  # we already gave warning; here, we force them to be nonfree
  if (categorical && parameterization == "delta") {
    ord.var.idx <- which(tmp.list$op == "~~" &
                         tmp.list$lhs == tmp.list$rhs &
                         tmp.list$lhs %in% ov.ord &
                         tmp.list$user == 1L)
    if (length(ord.var.idx) > 0L) {
      # force them to be nonfree and set ustart to 1 (new in 0.6-20)
      tmp.list$free[ord.var.idx]   <- rep(0L, length(ord.var.idx))
      tmp.list$ustart[ord.var.idx] <- rep(1,  length(ord.var.idx))
    }
  } # categorical


  # warning about single label in multiple group setting?
  if (warn.about.single.label) {
    lav_msg_warn(gettext(
      "using a single label per parameter in a multiple group setting implies
      imposing equality constraints across all the groups; If this is not
      intended, either remove the label(s), or use a vector of labels (one for
      each group); See the Multiple groups section in the man page of
      model.syntax."
    ))
  }

  # if lower/upper values were added, fix non-free values to ustart values
  # new in 0.6-6
  if (!is.null(tmp.list$lower)) {
    fixed.idx <- which(tmp.list$free == 0L)
    if (length(fixed.idx) > 0L) {
      tmp.list$lower[fixed.idx] <- tmp.list$ustart[fixed.idx]
    }
  }
  if (!is.null(tmp.list$upper)) {
    fixed.idx <- which(tmp.list$free == 0L)
    if (length(fixed.idx) > 0L) {
      tmp.list$upper[fixed.idx] <- tmp.list$ustart[fixed.idx]
    }
  }

  # if rv column is present, add rv.names to ALL rows where they are used
  if (!is.null(tmp.list$rv)) {
    rv.names <- unique(tmp.list$rv[nchar(tmp.list$rv) > 0L])
    for (i in seq_len(length(rv.names))) {
      lhs.idx <- which(tmp.list$lhs == rv.names[i] &
        tmp.list$op == "=~")
      tmp.list$rv[lhs.idx] <- rv.names[i]
    }
  }

  if (lav_debug()) {
    cat("[lavaan DEBUG]: parameter tmp.list with MODIFIERS:\n")
    print(as.data.frame(tmp.list, stringsAsFactors = FALSE))
  }

  # get 'virtual' parameter labels
  if (n.block.flat > 1L) {
    blocks <- tmp.block.lhs
  } else {
    blocks <- "group"
  }
  label <- lav_partable_labels(
    partable = tmp.list,
    blocks = blocks,
    group.equal = group.equal,
    group.partial = group.partial
  )

  if (lav_debug()) {
    cat("[lavaan DEBUG]: parameter tmp.list with LABELS:\n")
    tmp <- tmp.list
    tmp$label <- label
    print(as.data.frame(tmp, stringsAsFactors = FALSE))
  }

  # handle EFA equality constraints
  # YR 14 Jan 2020: 0.6-6 does no longer impose 'explicit' constraints
  #                 if we only need to fix a parameter to 0/1
  # Note: we should also check if they are really needed:
  #       eg., if all the factor-loadings of the 'second' set (time/group)
  #       are constrained to be equal to the factor-loadings of the first
  #       set, no further constraints are needed
  if (auto.efa && !is.null(tmp.list$efa)) {
    tmp.list <- lav_partable_efa_constraints(
      LIST = tmp.list,
      orthogonal.efa = orthogonal.efa,
      group.equal = group.equal
    )
  } # auto.efa

  # handle user-specified equality constraints
  # lavaan 0.6-11:
  #     two settings:
  #       1) simple equality constraints ONLY -> back to basics: only
  #          duplicate 'free' numbers; no longer explicit == rows with plabels
  #       2) mixture of simple and other (explicit) constraints
  #          treat them together as we did in <0.6-11
  tmp.list$plabel <- paste(".p", tmp.list$id, ".", sep = "")
  eq.labels <- unique(label[duplicated(label)])
  eq.id <- integer(length(tmp.list$lhs))
  for (eq.label in eq.labels) {
    tmp.con.idx <- length(tmp.con)
    all.idx <- which(label == eq.label) # all same-label parameters
    ref.idx <- all.idx[1L] # the first one only
    other.idx <- all.idx[-1L] # the others
    eq.id[all.idx] <- ref.idx

    # new in 0.6-6: make sure lower/upper constraints are equal too
    if (!is.null(tmp.list$lower) &&
      length(unique(tmp.list$lower[all.idx])) > 0L) {
      non.inf <- which(is.finite(tmp.list$lower[all.idx]))
      if (length(non.inf) > 0L) {
        smallest.val <- min(tmp.list$lower[all.idx][non.inf])
        tmp.list$lower[all.idx] <- smallest.val
      }
    }
    if (!is.null(tmp.list$upper) &&
      length(unique(tmp.list$upper[all.idx])) > 0L) {
      non.inf <- which(is.finite(tmp.list$upper[all.idx]))
      if (length(non.inf) > 0L) {
        largest.val <- max(tmp.list$upper[all.idx][non.inf])
        tmp.list$upper[all.idx] <- largest.val
      }
    }

    # two possibilities:
    #   1. all.idx contains a fixed parameter: in this case,
    #      we fix them all (hopefully to the same value)
    #   2. all.idx contains only free parameters

    # 1. all.idx contains a fixed parameter
    if (any(tmp.list$free[all.idx] == 0L)) {
      # which one is fixed?
      fixed.all <- all.idx[tmp.list$free[all.idx] == 0L]
      # only pick the first
      fixed.idx <- fixed.all[1]

      # sanity check: are all ustart values equal?
      ustart1 <- tmp.list$ustart[fixed.idx]
      if (all(is.na(tmp.list$ustart[fixed.all]))) {
        # nothing to do; ustart values have not been set yet
      } else if (!all(ustart1 == tmp.list$ustart[fixed.all])) {
        lav_msg_warn(gettext(
          "equality constraints involve fixed parameters with different values;
          only the first one will be used"))
      }

      # make them all fixed
      tmp.list$ustart[all.idx] <- tmp.list$ustart[fixed.idx]
      tmp.list$free[all.idx] <- 0L # not free anymore, since it must
      # be equal to the 'fixed' parameter
      # (Note: Mplus ignores this)
      eq.id[all.idx] <- 0L # remove from eq.id list

      # new in 0.6-8 (for efa + user-specified eq constraints)
      if (any(tmp.list$user[all.idx] %in% c(7L, 77L))) {
        # if involved in an efa block, store in tmp.con anyway
        # we may need it for the rotated solution
        for (o in other.idx) {
          tmp.con.idx <- tmp.con.idx + 1L
          tmp.con[[tmp.con.idx]] <- list(
            op = "==",
            lhs = tmp.list$plabel[ref.idx],
            rhs = tmp.list$plabel[o],
            user = 2L
          )
        }
      }
    } else {
      # 2. all.idx contains only free parameters
      # old system:
      # - add tmp.con entry
      # - in 0.6-11: only if tmp.con is not empty
      if (!ceq.simple) {
        for (o in other.idx) {
          tmp.con.idx <- tmp.con.idx + 1L
          tmp.con[[tmp.con.idx]] <- list(
            op = "==",
            lhs = tmp.list$plabel[ref.idx],
            rhs = tmp.list$plabel[o],
            user = 2L
          )
        }
      } else {
        # new system:
        # - set $free elements to zero, and later to ref id
        tmp.list$free[other.idx] <- 0L # all but the first are non-free
        # but will get a duplicated number
      }

      # just to trick semTools, also add something in the label
      # colum, *if* it is empty
      # update: 0.6-11 we keep this, because it shows the plabels
      #         when eg group.equal = "loadings"
      for (i in all.idx) {
        if (nchar(tmp.list$label[i]) == 0L) {
          tmp.list$label[i] <- tmp.list$plabel[ref.idx]
        }
      }
    } # all free
  } # eq in eq.labels
  if (lav_debug()) {
    print(tmp.con)
  }



  # handle constraints (if any) (NOT per group, but overall - 0.4-11)
  if (length(tmp.con) > 0L) {
    n.con <- length(tmp.con)
    tmp.idx <- length(tmp.list$id) + seq_len(n.con)
    # grow tmp.list with length(tmp.con) extra rows
    tmp.list <- lapply(tmp.list, function(x) {
      if (is.character(x)) {
        c(x, rep("", n.con))
      } else {
        c(x, rep(NA, n.con))
      }
    })

    # fill in some columns
    tmp.list$id[tmp.idx] <- tmp.idx
    tmp.list$lhs[tmp.idx] <- unlist(lapply(tmp.con, "[[", "lhs"))
    tmp.list$op[tmp.idx] <- unlist(lapply(tmp.con, "[[", "op"))
    tmp.list$rhs[tmp.idx] <- unlist(lapply(tmp.con, "[[", "rhs"))
    tmp.list$user[tmp.idx] <- unlist(lapply(tmp.con, "[[", "user"))

    # zero is nicer?
    tmp.list$free[tmp.idx] <- rep(0L, n.con)
    tmp.list$exo[tmp.idx] <- rep(0L, n.con)
    tmp.list$block[tmp.idx] <- rep(0L, n.con)

    if (!is.null(tmp.list$group)) {
      if (is.character(tmp.list$group)) {
        tmp.list$group[tmp.idx] <- rep("", n.con)
      } else {
        tmp.list$group[tmp.idx] <- rep(0L, n.con)
      }
    }
    if (!is.null(tmp.list$level)) {
      if (is.character(tmp.list$level)) {
        tmp.list$level[tmp.idx] <- rep("", n.con)
      } else {
        tmp.list$level[tmp.idx] <- rep(0L, n.con)
      }
    }
    if (!is.null(tmp.list$class)) {
      if (is.character(tmp.list$class)) {
        tmp.list$class[tmp.idx] <- rep("", n.con)
      } else {
        tmp.list$class[tmp.idx] <- rep(0L, n.con)
      }
    }
  }

  # check defined variables (:=)
  def.idx <- which(tmp.list$op == ":=")
  if (length(def.idx) > 0L) {
    # check if the lhs is unique (new in 0.6-20)
    def.lhs <- tmp.list$lhs[def.idx]
    dup.idx <- which(duplicated(def.lhs))
    if (length(dup.idx) > 0L) {
      # warn or stop? warn for now
      lav_msg_warn(gettextf("at least one defined variable (using the :=
                             operator) has been duplicated, and will be
                             overwritten by the last one: %s",
                            paste(def.lhs[dup.idx], collapse = " ")))
    }
    # put lhs of := elements in label column
    tmp.list$label[def.idx] <- def.lhs
  }


  # handle effect.coding related equality constraints
  if (is.logical(effect.coding) && effect.coding) {
    effect.coding <- c("loadings", "intercepts")
  } else if (!is.character(effect.coding)) {
    lav_msg_stop(gettext("effect.coding argument must be a character string"))
  }
  if (any(c("loadings", "intercepts") %in% effect.coding)) {
    tmp <- list()
    # for each block
    nblocks <- lav_partable_nblocks(tmp.list)
    for (b in seq_len(nblocks)) {

      # which group?
      this.group <- floor(b / nlevels + 0.5)

      # lv's for this block/set
      lv.names <- unique(tmp.list$lhs[tmp.list$op == "=~" &
        tmp.list$block == b])

      if (length(lv.names) == 0L) {
        next
      }

      int.plabel <- character(0L)
      for (lv in lv.names) {
        # ind.names
        ind.names <- tmp.list$rhs[tmp.list$op == "=~" &
          tmp.list$block == b &
          tmp.list$lhs == lv]

        if ("loadings" %in% effect.coding &
            (!"loadings" %in% group.equal || this.group == 1L)) {
          # factor loadings indicators of this lv
          loadings.idx <- which(tmp.list$op == "=~" &
            tmp.list$block == b &
            tmp.list$rhs %in% ind.names &
            tmp.list$lhs == lv)

          # all free?
          if (length(loadings.idx) > 0L &&
            all(tmp.list$free[loadings.idx] > 0L)) {
            # add eq constraint
            plabel <- tmp.list$plabel[loadings.idx]

            # Note:  we write them as
            # .p1. == 3 - .p2. - .p3.
            # instead of
            # 3 ==  .p1.+.p2.+.p3.
            # as this makes it easier to translate things to
            # JAGS/stan

            tmp.lhs <- plabel[1]
            if (length(loadings.idx) > 1L) {
              tmp.rhs <- paste(length(loadings.idx), "-",
                paste(plabel[-1], collapse = "-"),
                sep = ""
              )
            } else {
              tmp.rhs <- length(loadings.idx)
            }

            tmp$lhs <- c(tmp$lhs, tmp.lhs)
            tmp$op <- c(tmp$op, "==")
            tmp$rhs <- c(tmp$rhs, tmp.rhs)
            tmp$block <- c(tmp$block, 0L)
            tmp$user <- c(tmp$user, 2L)
            tmp$ustart <- c(tmp$ustart, as.numeric(NA))
          }
        } # loadings

        if ("intercepts" %in% effect.coding &
            (!"intercepts" %in% group.equal || this.group == 1L)) {
          # intercepts for indicators of this lv
          intercepts.idx <- which(tmp.list$op == "~1" &
            tmp.list$block == b &
            tmp.list$lhs %in% ind.names)

          # all free?
          if (length(intercepts.idx) > 0L &&
            all(tmp.list$free[intercepts.idx] > 0L)) {
            # 1) add eq constraint
            plabel <- tmp.list$plabel[intercepts.idx]

            tmp.lhs <- plabel[1]
            if (length(intercepts.idx) > 1L) {
              tmp.rhs <- paste("0-",
                paste(plabel[-1], collapse = "-"),
                sep = ""
              )
            } else {
              tmp.rhs <- 0L
            }

            tmp$lhs <- c(tmp$lhs, tmp.lhs)
            tmp$op <- c(tmp$op, "==")
            tmp$rhs <- c(tmp$rhs, tmp.rhs)
            tmp$block <- c(tmp$block, 0L)
            tmp$user <- c(tmp$user, 2L)
            tmp$ustart <- c(tmp$ustart, as.numeric(NA))

            # 2) release latent mean
            lv.int.idx <- which(tmp.list$op == "~1" &
              tmp.list$block == b &
              tmp.list$lhs == lv)
            # free only if automatically added
            if (length(lv.int.idx) > 0L &&
              tmp.list$user[lv.int.idx] == 0L) {
              tmp.list$free[lv.int.idx] <- 1L
            }
          }
        } # intercepts
      } # lv
    } # blocks

    tmp.list <- lav_partable_merge(tmp.list, tmp)
  }

  # marker.int.zero
  if (meanstructure && marker.int.zero) {
    # for each block
    nblocks <- lav_partable_nblocks(tmp.list)
    for (b in seq_len(nblocks)) {
      # lv's for this block/set
      lv.names <- lav_partable_vnames(tmp.list,
        type = "lv.regular",
        block = b
      )
      lv.marker <- lav_partable_vnames(tmp.list,
        type = "lv.regular",
        block = b
      )

      if (length(lv.names) == 0L) {
        next
      }

      # markers for this block
      lv.marker <- lav_partable_vnames(tmp.list,
        type = "lv.marker",
        block = b
      )

      # fix marker intercepts to zero
      marker.idx <- which(tmp.list$op == "~1" &
        tmp.list$lhs %in% lv.marker & tmp.list$block == b &
        tmp.list$user == 0L)
      tmp.list$free[marker.idx] <- 0L
      tmp.list$ustart[marker.idx] <- 0

      # free latent means
      lv.idx <- which(tmp.list$op == "~1" &
        tmp.list$lhs %in% lv.names & tmp.list$block == b &
        tmp.list$user == 0L)
      tmp.list$free[lv.idx] <- 1L
      tmp.list$ustart[lv.idx] <- as.numeric(NA)
    } # block
  }


  # mg.lv.variances
  if (ngroups > 1L && "mg.lv.variances" %in% effect.coding) {
    tmp <- list()

    # do not include 'EFA' lv's
    if (!is.null(tmp.list$efa)) {
      lv.names <- unique(tmp.list$lhs[tmp.list$op == "=~" &
        !nchar(tmp.list$efa) > 0L])
    } else {
      lv.names <- unique(tmp.list$lhs[tmp.list$op == "=~"])
    }
    group.values <- lav_partable_group_values(tmp.list)

    for (lv in lv.names) {
      # factor variances
      lv.var.idx <- which(tmp.list$op == "~~" &
        tmp.list$lhs == lv &
        tmp.list$rhs == tmp.list$lhs &
        tmp.list$lhs == lv)

      # all free (but the first?)
      if (length(lv.var.idx) > 0L &&
        all(tmp.list$free[lv.var.idx][-1] > 0L)) {
        # 1) add eq constraint
        plabel <- tmp.list$plabel[lv.var.idx]

        tmp.lhs <- plabel[1]
        if (length(lv.var.idx) > 1L) {
          tmp.rhs <- paste(length(lv.var.idx), "-",
            paste(plabel[-1], collapse = "-"),
            sep = ""
          )
        } else {
          tmp.rhs <- length(lv.var.idx)
        }

        tmp$lhs <- c(tmp$lhs, tmp.lhs)
        tmp$op <- c(tmp$op, "==")
        tmp$rhs <- c(tmp$rhs, tmp.rhs)
        tmp$block <- c(tmp$block, 0L)
        tmp$user <- c(tmp$user, 2L)
        tmp$ustart <- c(tmp$ustart, as.numeric(NA))

        # 2) free lv variances first group
        lv.var.g1.idx <- which(tmp.list$op == "~~" &
          tmp.list$group == group.values[1] &
          tmp.list$lhs == lv &
          tmp.list$rhs == tmp.list$lhs &
          tmp.list$lhs == lv)
        # free only if automatically added
        if (length(lv.var.g1.idx) > 0L &&
          tmp.list$user[lv.var.g1.idx] == 0L) {
          tmp.list$free[lv.var.g1.idx] <- 1L
        }
      }
    } # lv

    tmp.list <- lav_partable_merge(tmp.list, tmp)
  }

  # mg.lv.efa.variances
  if (ngroups > 1L && "mg.lv.efa.variances" %in% effect.coding) {
    tmp <- list()

    # only 'EFA' lv's
    if (!is.null(tmp.list$efa)) {
      lv.names <- unique(tmp.list$lhs[tmp.list$op == "=~" &
        nchar(tmp.list$efa) > 0L])
    } else {
      lv.names <- character(0L)
    }
    group.values <- lav_partable_group_values(tmp.list)

    for (lv in lv.names) {
      # factor variances
      lv.var.idx <- which(tmp.list$op == "~~" &
        tmp.list$lhs == lv &
        tmp.list$rhs == tmp.list$lhs &
        tmp.list$lhs == lv)

      # all free (but the first?)
      if (length(lv.var.idx) > 0L &&
        all(tmp.list$free[lv.var.idx][-1] > 0L)) {
        # 1) add eq constraint
        plabel <- tmp.list$plabel[lv.var.idx]

        tmp.lhs <- plabel[1]
        if (length(lv.var.idx) > 1L) {
          tmp.rhs <- paste(length(lv.var.idx), "-",
            paste(plabel[-1], collapse = "-"),
            sep = ""
          )
        } else {
          tmp.rhs <- length(lv.var.idx)
        }

        tmp$lhs <- c(tmp$lhs, tmp.lhs)
        tmp$op <- c(tmp$op, "==")
        tmp$rhs <- c(tmp$rhs, tmp.rhs)
        tmp$block <- c(tmp$block, 0L)
        tmp$user <- c(tmp$user, 2L)
        tmp$ustart <- c(tmp$ustart, as.numeric(NA))

        # 2) free lv variances first group
        lv.var.g1.idx <- which(tmp.list$op == "~~" &
          tmp.list$group == group.values[1] &
          tmp.list$lhs == lv &
          tmp.list$rhs == tmp.list$lhs &
          tmp.list$lhs == lv)
        # free only if automatically added
        if (length(lv.var.g1.idx) > 0L &&
          tmp.list$user[lv.var.g1.idx] == 0L) {
          tmp.list$free[lv.var.g1.idx] <- 1L
        }
      }
    } # lv

    tmp.list <- lav_partable_merge(tmp.list, tmp)
  }


  # count free parameters
  idx.free <- which(tmp.list$free > 0L)
  tmp.list$free[idx.free] <- seq_along(idx.free)

  # new in 0.6-11: add free counter to this element (as in < 0.5-18)
  # unless we have other constraints
  if (ceq.simple) {
    idx.equal <- which(eq.id > 0)
    tmp.list$free[idx.equal] <- tmp.list$free[eq.id[idx.equal]]
  }

  # new in 0.6-14: add 'da' entries to reflect data-based order of ov's
  # now via attribute "ovda"
  attr(tmp.list, "ovda") <- ov.names.data

  # backwards compatibility...
  if (!is.null(tmp.list$unco)) {
    tmp.list$unco[idx.free] <- seq_along(sum(tmp.list$free > 0L))
  }

  if (lav_debug()) {
    cat("[lavaan DEBUG] lavParTable\n")
    print(as.data.frame(tmp.list))
  }

  # data.frame?
  if (as.data.frame.) {
    tmp.list <- as.data.frame(tmp.list, stringsAsFactors = FALSE)
    attr(tmp.list, "ovda") <- ov.names.data
  } else {
    tmp.list <- lav_partable_set_cache(tmp.list) # add cached "pta" data
  }

  tmp.list
}
lavParTable <- lav_model_partable   # synonym #nolint
lavaanify <- lav_model_partable     # synonym #nolint

# build def function from partable
lav_partable_constraints_def <- function(partable, con = NULL, debug = FALSE,
                                         txtOnly = FALSE, warn = TRUE) {
  if (!missing(debug)) {
    current.debug <- lav_debug()
    if (lav_debug(debug))
      on.exit(lav_debug(current.debug), TRUE)
  }
  # empty function
  def.function <- function() NULL

  # if 'con', merge partable + con
  if (!is.null(con)) {
    partable$lhs <- c(partable$lhs, con$lhs)
    partable$op <- c(partable$op, con$op)
    partable$rhs <- c(partable$rhs, con$rhs)
  }

  # get := definitions
  def.idx <- which(partable$op == ":=")

  # catch empty def
  if (length(def.idx) == 0L) {
    if (txtOnly) {
      return(character(0L))
    } else {
      return(def.function)
    }
  }

  # sort order of def.idx by dependencies
  deps <- lapply(partable$rhs[def.idx], FUN = function(x) {
                                                all.vars(parse(text=x)) })
  lab.unsorted <- partable$lhs[def.idx]
  adj.mat <- matrix(0L, nrow = length(def.idx), ncol = length(def.idx))
  for (i in seq_along(lab.unsorted)) {
    adj.mat[lab.unsorted %in% deps[[i]], i] <- 1L
  }
  def.idx <- def.idx[lav_graph_order_adj_mat(adj.mat, warn = warn)]

  # create function
  formals(def.function) <- alist(.x. = , ... = )
  if (txtOnly) {
    BODY.txt <- ""
  } else {
    BODY.txt <- paste("{\n# parameter definitions\n\n")
  }

  lhs.names <- partable$lhs[def.idx]
  def.labels <- all.vars(parse(file = "", text = partable$rhs[def.idx]))
  # remove the ones in lhs.names
  idx <- which(def.labels %in% lhs.names)
  if (length(idx) > 0L) def.labels <- def.labels[-idx]

  # get corresponding 'x' indices
  def.x.idx <- partable$free[match(def.labels, partable$label)]
  if (any(is.na(def.x.idx))) {
    lav_msg_stop(gettext(
      "unknown label(s) in variable definition(s):"),
      lav_msg_view(def.labels[which(is.na(def.x.idx))], "none")
    )
  }
  if (any(def.x.idx == 0)) {
    lav_msg_stop(gettext(
      "non-free parameter(s) in variable definition(s):"),
      lav_msg_view(def.labels[which(def.x.idx == 0)], "none")
    )
  }
  def.x.lab <- paste(".x.[", def.x.idx, "]", sep = "")
  # put both the labels the function BODY
  if (length(def.x.idx) > 0L) {
    BODY.txt <- paste(BODY.txt, "# parameter labels\n",
      paste(def.labels, " <- ", def.x.lab, collapse = "\n"),
      "\n",
      sep = ""
    )
  }

  # write the definitions literally
  BODY.txt <- paste(BODY.txt, "\n# parameter definitions\n", sep = "")
  for (i in 1:length(def.idx)) {
    BODY.txt <- paste(BODY.txt,
      lhs.names[i], " <- ", partable$rhs[def.idx[i]], "\n",
      sep = ""
    )
  }

  if (txtOnly) {
    return(BODY.txt)
  }

  # put the results in 'out'
  BODY.txt <- paste(BODY.txt, "\nout <- ",
    paste("c(", paste(lhs.names, collapse = ","), ")\n", sep = ""),
    sep = ""
  )
  # what to do with NA values? -> return +Inf???
  BODY.txt <- paste(BODY.txt, "out[is.na(out)] <- Inf\n", sep = "")
  BODY.txt <- paste(BODY.txt, "names(out) <- ",
    paste("c(\"", paste(lhs.names, collapse = "\",\""), "\")\n", sep = ""),
    sep = ""
  )
  BODY.txt <- paste(BODY.txt, "return(out)\n}\n", sep = "")

  body(def.function) <- parse(file = "", text = BODY.txt)
  if (lav_debug()) {
    cat("def.function = \n")
    print(def.function)
    cat("\n")
  }

  def.function
}

# build ceq function from partable
#     non-trivial equality constraints (linear or nonlinear)
#     convert to 'ceq(x)' function where 'x' is the (free) parameter vector
#     and ceq(x) returns the evaluated equality constraints
#
#     eg. if b1 + b2 == 2 (and b1 correspond to, say,  x[10] and x[17])
#         ceq <- function(x) {
#             out <- rep(NA, 1)
#             b1 = x[10]; b2 = x[17]
#             out[1] <- b1 + b2 - 2
#         }
lav_partable_constraints_ceq <- function(partable, con = NULL, debug = FALSE,
                                         txtOnly = FALSE) {
  if (!missing(debug)) {
    current.debug <- lav_debug()
    if (lav_debug(debug))
      on.exit(lav_debug(current.debug), TRUE)
  }
  # empty function
  ceq.function <- function() NULL

  # if 'con', merge partable + con
  if (!is.null(con)) {
    partable$lhs <- c(partable$lhs, con$lhs)
    partable$op <- c(partable$op, con$op)
    partable$rhs <- c(partable$rhs, con$rhs)
  }

  # get equality constraints
  eq.idx <- which(partable$op == "==")

  # catch empty ceq
  if (length(eq.idx) == 0L) {
    if (txtOnly) {
      return(character(0L))
    } else {
      return(ceq.function)
    }
  }

  # create function
  formals(ceq.function) <- alist(.x. = , ... = )
  if (txtOnly) {
    BODY.txt <- ""
  } else {
    BODY.txt <- paste("{\nout <- rep(NA, ", length(eq.idx), ")\n", sep = "")
  }

  # first come the variable definitions
  DEF.txt <- lav_partable_constraints_def(partable, txtOnly = TRUE,
                                          warn = FALSE)
  def.idx <- which(partable$op == ":=")
  BODY.txt <- paste(BODY.txt, DEF.txt, "\n", sep = "")


  # extract labels
  lhs.labels <- all.vars(parse(file = "", text = partable$lhs[eq.idx]))
  rhs.labels <- all.vars(parse(file = "", text = partable$rhs[eq.idx]))
  eq.labels <- unique(c(lhs.labels, rhs.labels))
  # remove def.names from eq.labels
  if (length(def.idx) > 0L) {
    def.names <- as.character(partable$lhs[def.idx])
    d.idx <- which(eq.labels %in% def.names)
    if (length(d.idx) > 0) eq.labels <- eq.labels[-d.idx]
  }
  eq.x.idx <- rep(as.integer(NA), length(eq.labels))
  # get user-labels ids
  ulab.idx <- which(eq.labels %in% partable$label)
  if (length(ulab.idx) > 0L) {
    eq.x.idx[ulab.idx] <- partable$free[match(
      eq.labels[ulab.idx],
      partable$label
    )]
  }
  # get plabels ids
  plab.idx <- which(eq.labels %in% partable$plabel)
  if (length(plab.idx) > 0L) {
    eq.x.idx[plab.idx] <- partable$free[match(
      eq.labels[plab.idx],
      partable$plabel
    )]
  }

  # check if we have found the label
  if (any(is.na(eq.x.idx))) {
    lav_msg_stop(gettext("unknown label(s) in equality constraint(s):"),
      lav_msg_view(eq.labels[which(is.na(eq.x.idx))], "none")
    )
  }
  # check if they are all 'free'
  if (any(eq.x.idx == 0)) {
    fixed.eq.idx <- which(eq.x.idx == 0)
    # FIXME: what should we do here? we used to stop with an error
    # from 0.5.18, we give a warning, and replace the non-free label
    # with its fixed value in ustart
    # warning("lavaan WARNING: non-free parameter(s) in equality constraint(s): ",
    #    paste(eq.labels[fixed.eq.idx], collapse=" "))

    fixed.lab.lhs <- eq.labels[fixed.eq.idx]
    fixed.lab.rhs <- numeric(length(fixed.lab.lhs))

    for (i in 1:length(fixed.lab.lhs)) {
      # first try label
      idx <- match(fixed.lab.lhs[i], partable$label)
      # then try plabel
      if (is.na(idx)) {
        idx <- match(fixed.lab.lhs[i], partable$plabel)
      }
      if (is.na(idx)) {
        # hm, not found? fill in zero, or NA?
      } else {
        fixed.lab.rhs[i] <- partable$ustart[idx]
      }
    }

    BODY.txt <- paste(BODY.txt, "# non-free parameter labels\n",
      paste(fixed.lab.lhs, "<-", fixed.lab.rhs, collapse = "\n"),
      "\n",
      sep = ""
    )

    eq.x.idx <- eq.x.idx[-fixed.eq.idx]
    eq.labels <- eq.labels[-fixed.eq.idx]
  }

  # put the labels the function BODY
  eq.x.lab <- paste(".x.[", eq.x.idx, "]", sep = "")
  if (length(eq.x.idx) > 0L) {
    BODY.txt <- paste(BODY.txt, "# parameter labels\n",
      paste(eq.labels, "<-", eq.x.lab, collapse = "\n"),
      "\n",
      sep = ""
    )
  }

  # write the equality constraints literally
  BODY.txt <- paste(BODY.txt, "\n# equality constraints\n", sep = "")
  for (i in 1:length(eq.idx)) {
    lhs <- partable$lhs[eq.idx[i]]
    rhs <- partable$rhs[eq.idx[i]]
    if (rhs == "0") {
      eq.string <- lhs
    } else {
      eq.string <- paste(lhs, " - (", rhs, ")", sep = "")
    }
    BODY.txt <- paste(BODY.txt, "out[", i, "] <- ", eq.string, "\n", sep = "")
  }

  if (txtOnly) {
    return(BODY.txt)
  }

  # put the results in 'out'
  # BODY.txt <- paste(BODY.txt, "\nout <- ",
  #    paste("c(", paste(lhs.names, collapse=","),")\n", sep=""), sep="")

  # what to do with NA values? -> return +Inf???
  BODY.txt <- paste(BODY.txt, "\n", "out[is.na(out)] <- Inf\n", sep = "")
  BODY.txt <- paste(BODY.txt, "return(out)\n}\n", sep = "")
  body(ceq.function) <- parse(file = "", text = BODY.txt)
  if (lav_debug()) {
    cat("ceq.function = \n")
    print(ceq.function)
    cat("\n")
  }

  ceq.function
}


# build ciq function from partable
#     non-trivial inequality constraints (linear or nonlinear)
#     convert to 'cin(x)' function where 'x' is the (free) parameter vector
#     and cin(x) returns the evaluated inequality constraints
#
#     eg. if b1 + b2 > 2 (and b1 correspond to, say,  x[10] and x[17])
#         cin <- function(x) {
#             out <- rep(NA, 1)
#             b1 = x[10]; b2 = x[17]
#             out[1] <- b1 + b2 - 2
#         }
#
#     new in 0.6-19: we also add the lower/upper bounds
#
# NOTE: very similar, but not identitical to ceq, because we need to take
#       care of the difference between '<' and '>'
lav_partable_constraints_ciq <- function(partable, con = NULL, debug = FALSE,
                                         txtOnly = FALSE) {
  if (!missing(debug)) {
    current.debug <- lav_debug()
    if (lav_debug(debug))
      on.exit(lav_debug(current.debug), TRUE)
  }
  # empty function
  cin.function <- function() NULL

  # if 'con', merge partable + con
  if (!is.null(con)) {
    partable$lhs <- c(partable$lhs, con$lhs)
    partable$op <- c(partable$op, con$op)
    partable$rhs <- c(partable$rhs, con$rhs)
  }

  # get explicit inequality constraints
  ineq.idx <- which(partable$op == ">" | partable$op == "<")

  # get lower/upper bounds
  upper.idx <- integer(0L)
  lower.idx <- integer(0L)
  if (!is.null(partable$upper)) {
    upper.idx <- which(partable$free > 0L  & is.finite(partable$upper))
  }
  if (!is.null(partable$lower)) {
    lower.idx <- which(partable$free > 0L & is.finite(partable$lower))
  }

  # add them to ineq.idx
  ineq.only.idx <- ineq.idx
  ineq.idx <- c(upper.idx, lower.idx, ineq.idx)

  # catch empty ciq
  if (length(ineq.idx) == 0L) {
    if (txtOnly) {
      return(character(0L))
    } else {
      return(cin.function)
    }
  }

  # create function
  formals(cin.function) <- alist(.x. = , ... = )
  if (txtOnly) {
    BODY.txt <- ""
  } else {
    BODY.txt <- paste("{\nout <- rep(NA, ", length(ineq.idx), ")\n", sep = "")
  }

  # first come the variable definitions
  DEF.txt <- lav_partable_constraints_def(partable, txtOnly = TRUE,
                                          warn = FALSE)
  def.idx <- which(partable$op == ":=")
  BODY.txt <- paste(BODY.txt, DEF.txt, "\n", sep = "")

  # extract labels
  lhs.labels <- all.vars(parse(file = "", text = partable$lhs[ineq.only.idx]))
  rhs.labels <- all.vars(parse(file = "", text = partable$rhs[ineq.only.idx]))
  ineq.labels <- unique(c(lhs.labels, rhs.labels))
  # remove def.names from ineq.labels
  if (length(def.idx) > 0L) {
    def.names <- as.character(partable$lhs[def.idx])
    d.idx <- which(ineq.labels %in% def.names)
    if (length(d.idx) > 0) ineq.labels <- ineq.labels[-d.idx]
  }
  ineq.x.idx <- rep(as.integer(NA), length(ineq.labels))
  # get user-labels ids
  ulab.idx <- which(ineq.labels %in% partable$label)
  if (length(ulab.idx) > 0L) {
    ineq.x.idx[ulab.idx] <- partable$free[match(
      ineq.labels[ulab.idx],
      partable$label
    )]
  }
  # get plabels ids
  plab.idx <- which(ineq.labels %in% partable$plabel)
  if (length(plab.idx) > 0L) {
    ineq.x.idx[plab.idx] <- partable$free[match(
      ineq.labels[plab.idx],
      partable$plabel
    )]
  }

  # check if we have found the label
  if (length(ineq.x.idx) > 0L && any(is.na(ineq.x.idx))) {
    lav_msg_stop(gettext("unknown label(s) in inequality constraint(s):"),
      lav_msg_view(ineq.labels[which(is.na(ineq.x.idx))], "none")
    )
  }

  # check if they are all 'free'
  if (length(ineq.x.idx) > 0L && any(ineq.x.idx == 0)) {
    fixed.ineq.idx <- which(ineq.x.idx == 0)
    # FIXME: what should we do here? we used to stop with an error
    # from 0.5.18, we give a warning, and replace the non-free label
    # with its fixed value in ustart
    lav_msg_warn(gettext("non-free parameter(s) in inequality constraint(s):"),
      lav_msg_view(ineq.labels[fixed.ineq.idx],"none")
    )

    fixed.lab.lhs <- ineq.labels[fixed.ineq.idx]
    fixed.lab.rhs <- partable$ustart[match(fixed.lab.lhs, partable$label)]
    BODY.txt <- paste(BODY.txt, "# non-free parameter labels\n",
      paste(fixed.lab.lhs, "<-", fixed.lab.rhs, collapse = "\n"),
      "\n",
      sep = ""
    )

    ineq.x.idx <- ineq.x.idx[-fixed.ineq.idx]
    ineq.labels <- ineq.labels[-fixed.ineq.idx]
  }

  # put the labels the function BODY
  if (length(ineq.x.idx) > 0L) {
    ineq.x.lab <- paste(".x.[", ineq.x.idx, "]", sep = "")
    if (length(ineq.x.idx) > 0L) {
      BODY.txt <- paste(BODY.txt, "# parameter labels\n",
        paste(ineq.labels, "<-", ineq.x.lab, collapse = "\n"),
        "\n",
        sep = ""
      )
    }
  }

  # write the constraints literally
  BODY.txt <- paste(BODY.txt, "\n# inequality constraints\n", sep = "")
  FREE <- partable$free
  FREE[FREE > 0] <- seq_len(length(FREE[FREE > 0]))
  for (i in 1:length(ineq.idx)) {
    lhs <- partable$lhs[ineq.idx[i]]
    op <- partable$op[ineq.idx[i]]
    rhs <- partable$rhs[ineq.idx[i]]

    if (ineq.idx[i] %in% ineq.only.idx) {
      # EXPLICIT inequality constraints
      # note,this is different from ==, because we have < AND >
      if (rhs == "0" && op == ">") {
        ineq.string <- lhs
      } else if (rhs == "0" && op == "<") {
        ineq.string <- paste(rhs, " - (", lhs, ")", sep = "")
      } else if (rhs != "0" && op == ">") {
        ineq.string <- paste(lhs, " - (", rhs, ")", sep = "")
      } else if (rhs != "0" && op == "<") {
        ineq.string <- paste(rhs, " - (", lhs, ")", sep = "")
      }
    } else if (ineq.idx[i] %in% upper.idx) {
      # simple upper bound
      val <- partable$upper[ineq.idx[i]]
      xlab <- paste(".x.[", FREE[ineq.idx[i]], "]", sep = "")
      ineq.string <- paste(val, " - (", xlab, ")", sep = "")
    } else if (ineq.idx[i] %in% lower.idx) {
      # simple lower bound
      val <- partable$lower[ineq.idx[i]]
      xlab <- paste(".x.[", FREE[ineq.idx[i]], "]", sep = "")
      ineq.string <- paste(xlab, " - (", val, ")", sep = "")
    }

    BODY.txt <- paste(BODY.txt, "out[", i, "] <- ", ineq.string, "\n", sep = "")
  }

  if (txtOnly) {
    return(BODY.txt)
  }

  # put the results in 'out'
  BODY.txt <- paste(BODY.txt, "\n", "out[is.na(out)] <- Inf\n", sep = "")
  if (length(upper.idx) > 0L || length(lower.idx) > 0L) {
    bound.idx <- which(ineq.idx %in% c(upper.idx, lower.idx))
    bound.txt <- paste("c(", paste(bound.idx, collapse = ", "), ")", sep = "")
    BODY.txt <- paste(BODY.txt, "attr(out, \"bound.idx\") <- ", bound.txt,
                      "\n", sep = "")
  }
  BODY.txt <- paste(BODY.txt, "return(out)\n}\n", sep = "")
  body(cin.function) <- parse(file = "", text = BODY.txt)
  if (lav_debug()) {
    cat("cin.function = \n")
    print(cin.function)
    cat("\n")
  }

  cin.function
}

# return a named vector of the 'free' indices, for the labels that
# are used in a constrained (or optionally a definition)
# (always 0 for definitions)
lav_partable_constraints_label_id <- function(partable, con = NULL,
                                              def = TRUE) {
  # if 'con', merge partable + con
  if (!is.null(con)) {
    partable$lhs <- c(partable$lhs, con$lhs)
    partable$op <- c(partable$op, con$op)
    partable$rhs <- c(partable$rhs, con$rhs)
  }

  # get constraints
  if (def) {
    con.idx <- which(partable$op %in% c("==", "<", ">", ":="))
  } else {
    con.idx <- which(partable$op %in% c("==", "<", ">"))
  }

  # catch empty con
  if (length(con.idx) == 0L) {
    return(integer(0L))
  }

  def.idx <- which(partable$op == ":=")

  # extract labels
  lhs.labels <- all.vars(parse(file = "", text = partable$lhs[con.idx]))
  rhs.labels <- all.vars(parse(file = "", text = partable$rhs[con.idx]))
  con.labels <- unique(c(lhs.labels, rhs.labels))

  # remove def.names from con.labels (unless def = TRUE)
  if (!def && length(def.idx) > 0L) {
    def.names <- as.character(partable$lhs[def.idx])
    d.idx <- which(con.labels %in% def.names)
    if (length(d.idx) > 0) {
      con.labels <- con.labels[-d.idx]
    }
  }
  con.x.idx <- rep(as.integer(NA), length(con.labels))

  # get user-labels ids
  ulab.idx <- which(con.labels %in% partable$label)
  if (length(ulab.idx) > 0L) {
    con.x.idx[ulab.idx] <- partable$free[match(
      con.labels[ulab.idx],
      partable$label
    )]
  }
  # get plabels ids
  plab.idx <- which(con.labels %in% partable$plabel)
  if (length(plab.idx) > 0L) {
    con.x.idx[plab.idx] <- partable$free[match(
      con.labels[plab.idx],
      partable$plabel
    )]
  }

  # check if we have found the label
  if (any(is.na(con.x.idx))) {
    lav_msg_warn(gettext("unknown label(s) in equality constraint(s):"),
      lav_msg_view(con.labels[which(is.na(con.x.idx))], "none")
    )
  }

  # return named integer vector
  names(con.x.idx) <- con.labels

  con.x.idx
}


# constructor for the 'lavSampleStats' class
#
# initial version: YR 25/03/2009
# major revision: YR 5/11/2011: separate data.obs and sample statistics
# YR 5/01/2016: add rescov, resvar, ... if conditional.x = TRUE

# YR 18 Jan 2021: use lavoptions

lav_samplestats_from_data <- function(lavdata = NULL,
                                      lavoptions = NULL,
                                      WLS.V = NULL,
                                      NACOV = NULL) {
  # extra info from lavoptions
  stopifnot(!is.null(lavoptions))
  missing <- lavoptions$missing
  rescale <- lavoptions$sample.cov.rescale
  estimator <- lavoptions$estimator
  mimic <- lavoptions$mimic
  meanstructure <- lavoptions$meanstructure
  correlation <- lavoptions$correlation
  conditional.x <- lavoptions$conditional.x
  fixed.x <- lavoptions$fixed.x
  group.w.free <- lavoptions$group.w.free
  se <- lavoptions$se
  test <- lavoptions$test
  ridge <- lavoptions$ridge
  zero.add <- lavoptions$zero.add
  zero.keep.margins <- lavoptions$zero.keep.margins
  zero.cell.warn <- lavoptions$zero.cell.warn
  allow.empty.cell <- lavoptions$allow.empty.cell
  dls.a <- lavoptions$estimator.args$dls.a
  dls.GammaNT <- lavoptions$estimator.args$dls.GammaNT

  # sample.icov (new in 0.6-9; ensure it exists, for older objects)
  sample.icov <- TRUE
  if (!is.null(lavoptions$sample.icov)) {
    sample.icov <- lavoptions$sample.icov
  }

  # ridge default
  if (ridge) {
    if (is.numeric(lavoptions$ridge.constant)) {
      ridge.eps <- lavoptions$ridge.constant
    } else {
      ridge.eps <- 1e-5
    }
  } else {
    ridge.eps <- 0.0
  }

  # check lavdata
  stopifnot(!is.null(lavdata))

  # lavdata slots (FIXME: keep lavdata@ names)
  X <- lavdata@X
  Mp <- lavdata@Mp
  ngroups <- lavdata@ngroups
  nlevels <- lavdata@nlevels
  nobs <- lavdata@nobs
  ov.names <- lavdata@ov.names
  ov.names.x <- lavdata@ov.names.x
  DataOv <- lavdata@ov
  eXo <- lavdata@eXo
  WT <- lavdata@weights

  # new in 0.6-6
  # if sampling weights have been used, redefine nobs:
  # per group, we define nobs == sum(wt)
  for (g in seq_len(ngroups)) {
    if (!is.null(WT[[g]])) {
      nobs[[g]] <- sum(WT[[g]])
    }
  }

  # sample.cov.robust cannot be used if sampling weights are used
  if (lavoptions$sample.cov.robust) {
    if (!is.null(WT[[1]])) {
      lav_msg_stop(gettext(
        "sample.cov.robust = TRUE does not work (yet)
        if sampling weights are provided."))
    }
  }

  # sample statistics per group

  # joint (y,x)
  cov <- vector("list", length = ngroups)
  var <- vector("list", length = ngroups)
  mean <- vector("list", length = ngroups)
  th <- vector("list", length = ngroups)
  th.idx <- vector("list", length = ngroups)
  th.names <- vector("list", length = ngroups)

  # residual (y | x)
  res.cov <- vector("list", length = ngroups)
  res.var <- vector("list", length = ngroups)
  res.th <- vector("list", length = ngroups)
  res.th.nox <- vector("list", length = ngroups)
  res.slopes <- vector("list", length = ngroups)
  res.int <- vector("list", length = ngroups)

  # fixed.x
  mean.x <- vector("list", length = ngroups)
  cov.x <- vector("list", length = ngroups)

  # binary/ordinal
  bifreq <- vector("list", length = ngroups)

  # extra sample statistics per group
  icov <- vector("list", length = ngroups)
  cov.log.det <- vector("list", length = ngroups)
  res.icov <- vector("list", length = ngroups)
  res.cov.log.det <- vector("list", length = ngroups)
  WLS.obs <- vector("list", length = ngroups)
  missing. <- vector("list", length = ngroups)
  missing.h1. <- vector("list", length = ngroups)
  missing.flag. <- FALSE
  zero.cell.tables <- vector("list", length = ngroups)
  YLp <- vector("list", length = ngroups)

  # group weights
  group.w <- vector("list", length = ngroups)

  # convenience? # FIXME!
  x.idx <- vector("list", length = ngroups)


  WLS.VD <- vector("list", length = ngroups)
  if (is.null(WLS.V)) {
    WLS.V <- vector("list", length = ngroups)
    WLS.V.user <- FALSE
  } else {
    if (!is.list(WLS.V)) {
      if (ngroups == 1L) {
        WLS.V <- list(WLS.V)
      } else {
        lav_msg_stop(gettextf(
          "WLS.V argument should be a list of length %s", ngroups)
        )
      }
    } else {
      if (length(WLS.V) != ngroups) {
        lav_msg_stop(gettextf(
          "WLS.V assumes %1$s groups; data contains %2$s groups",
          length(WLS.V), ngroups))
      }
    }

    # is WLS.V full? check first
    if (is.null(dim(WLS.V[[1]]))) {
      # we will assume it is the diagonal only
      WLS.VD <- WLS.V
      WLS.V <- lapply(WLS.VD, diag)
    } else {
      # create WLS.VD
      WLS.VD <- lapply(WLS.V, diag)
    }

    WLS.V.user <- TRUE
    # FIXME: check dimension of WLS.V!!
  }

  NACOV.compute <- FALSE # since 0.6-6
  if (is.null(NACOV)) {
    NACOV <- vector("list", length = ngroups)
    NACOV.user <- FALSE
    if (se %in% c("robust.sem", "robust.sem.nt") && missing == "listwise") {
      NACOV.compute <- TRUE
    }
    # note: test can be a vector...
    if (missing == "listwise" && any(test %in% c(
      "satorra.bentler",
      "mean.var.adjusted",
      "scaled.shifted"
    ))) {
      NACOV.compute <- TRUE
    }
  } else if (is.logical(NACOV)) {
    if (!NACOV) {
      NACOV.compute <- FALSE
    } else {
      NACOV.compute <- TRUE
    }
    NACOV.user <- FALSE
    NACOV <- vector("list", length = ngroups)
  } else {
    if (!is.list(NACOV)) {
      if (ngroups == 1L) {
        NACOV <- list(NACOV)
      } else {
        lav_msg_stop(gettextf(
          "NACOV argument should be a list of length ", ngroups))
      }
    } else {
      if (length(NACOV) != ngroups) {
        lav_msg_stop(gettextf(
          "NACOV assumes %1$s groups; data contains %2$s groups",
          length(NACOV), ngroups))
      }
    }
    NACOV.user <- TRUE
    # FIXME: check dimension of NACOV!!
  }



  # compute some sample statistics per group
  for (g in 1:ngroups) {
    # switch off computing all sample statistics? (housekeeping only)
    if (!is.null(lavoptions$samplestats) && !lavoptions$samplestats) {
	  next
	}
    # check nobs
    if (is.null(WT[[g]])) {
      if (nobs[[g]] < 2L) {
        if (nobs[[g]] == 0L) {
          if (ngroups > 1L) {
            lav_msg_stop(gettextf("data contains no observations in
                                   group %s", g))
          } else {
            lav_msg_stop(gettext("data contains no observations"))
          }
        } else {
          if (ngroups > 1L) {
            lav_msg_stop(gettextf("data contains only a single observation
                                   in group %s", g))
          } else {
            lav_msg_stop(gettext("data contains only a single observation"))
          }
        }
      }
    }

    # exogenous x?
    nexo <- length(ov.names.x[[g]])
    if (nexo) {
      stopifnot(nexo == NCOL(eXo[[g]]))

      # two cases: ov.names contains 'x' variables, or not
      if (conditional.x) {
        # ov.names.x are NOT in ov.names
        x.idx[[g]] <- length(ov.names[[g]]) + seq_len(nexo)
      } else {
        if (fixed.x) {
          # ov.names.x are a subset of ov.names
          x.idx[[g]] <- match(ov.names.x[[g]], ov.names[[g]])
          stopifnot(!anyNA(x.idx[[g]]))
        } else {
          x.idx[[g]] <- integer(0L)
        }
      }
    } else {
      x.idx[[g]] <- integer(0L)
      conditional.x <- FALSE
      fixed.x <- FALSE
    }

    # group weight
    group.w[[g]] <- nobs[[g]] / sum(unlist(nobs))

    # check if we have categorical data in this group
    categorical <- FALSE
    ov.types <- DataOv$type[match(ov.names[[g]], DataOv$name)]
    ov.levels <- DataOv$nlev[match(ov.names[[g]], DataOv$name)]
    CAT <- list()
    if ("ordered" %in% ov.types) {
      categorical <- TRUE
      if (nlevels > 1L) {
        lav_msg_warn(gettext("multilevel + categorical not supported yet."))
      }
    }

    if (categorical) {
      # compute CAT

      if (estimator %in% c("ML", "REML", "PML", "FML", "MML", "none", "ULS")) {
        WLS.W <- FALSE
        if (estimator == "ULS" && se %in% c("robust.sem", "robust.sem.nt")) {
          WLS.W <- TRUE
        }
      } else {
        WLS.W <- TRUE
      }
	  # check cat.wls.w option (new in 0.6-18)
	  if (!is.null(lavoptions$cat.wls.w) && !lavoptions$cat.wls.w) {
	    WLS.W <- FALSE # perhaps do.fit = FALSE? (eg sam())
	  }
      if (lav_verbose()) {
        cat("Estimating sample thresholds and correlations ... ")
      }

      current.verbose <- lav_verbose()
      if (lav_verbose(lav_debug()))
        on.exit(lav_verbose(current.verbose), TRUE)
      if (conditional.x) {
        CAT <- muthen1984(
          Data = X[[g]],
          wt = WT[[g]],
          ov.names = ov.names[[g]],
          ov.types = ov.types,
          ov.levels = ov.levels,
          ov.names.x = ov.names.x[[g]],
          eXo = eXo[[g]],
          group = g, # for error messages only
          WLS.W = WLS.W,
          zero.add = zero.add,
          zero.keep.margins = zero.keep.margins,
          zero.cell.warn = FALSE,
          zero.cell.tables = TRUE,
          allow.empty.cell = allow.empty.cell
        )
      } else {
        CAT <- muthen1984(
          Data = X[[g]],
          wt = WT[[g]],
          ov.names = ov.names[[g]],
          ov.types = ov.types,
          ov.levels = ov.levels,
          ov.names.x = NULL,
          eXo = NULL,
          group = g, # for error messages only
          WLS.W = WLS.W,
          zero.add = zero.add,
          zero.keep.margins = zero.keep.margins,
          zero.cell.warn = FALSE,
          zero.cell.tables = TRUE,
          allow.empty.cell = allow.empty.cell
        )
      }
      lav_verbose(current.verbose)
      # empty cell tables
      zero.cell.tables[[g]] <- CAT$zero.cell.tables
      if (lav_verbose()) cat("done\n")
    }

    if (categorical) {
      # convenience
      th.idx[[g]] <- unlist(CAT$TH.IDX)
      th.names[[g]] <- unlist(CAT$TH.NAMES)

      if (conditional.x) {
        # residual var/cov
        res.var[[g]] <- unlist(CAT$VAR)
        res.cov[[g]] <- unname(CAT$COV)
        if (ridge) {
          diag(res.cov[[g]]) <- diag(res.cov[[g]]) + ridge.eps
          res.var[[g]] <- diag(res.cov[[g]])
        }

        # th also contains the means of numeric variables
        res.th[[g]] <- unlist(CAT$TH)
        res.th.nox[[g]] <- unlist(CAT$TH.NOX)

        # for convenience, we store the intercept of numeric
        # variables in res.int
        NVAR <- NCOL(res.cov[[g]])
        mean[[g]] <- res.int[[g]] <- numeric(NVAR)
        num.idx <- which(!seq_len(NVAR) %in% th.idx[[g]])
        if (length(num.idx) > 0L) {
          NUM.idx <- which(th.idx[[g]] == 0L)
          mean[[g]][num.idx] <- res.th.nox[[g]][NUM.idx]
          res.int[[g]][num.idx] <- res.th[[g]][NUM.idx]
        }

        # slopes
        res.slopes[[g]] <- CAT$SLOPES
      } else {
        # var/cov
        var[[g]] <- unlist(CAT$VAR)
        cov[[g]] <- unname(CAT$COV)
        if (ridge) {
          diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps
          var[[g]] <- diag(cov[[g]])
        }

        # th also contains the means of numeric variables
        th[[g]] <- unlist(CAT$TH)

        # mean (numeric only)
        NVAR <- NCOL(cov[[g]])
        mean[[g]] <- numeric(NVAR)
        num.idx <- which(!seq_len(NVAR) %in% th.idx[[g]])
        if (length(num.idx) > 0L) {
          NUM.idx <- which(th.idx[[g]] == 0L)
          mean[[g]][num.idx] <- th[[g]][NUM.idx]
        }
      }

      # only for catML
      if (estimator == "catML") {
        COV <- cov2cor(lav_matrix_symmetric_force_pd(cov[[g]],
          tol = 1e-04
        ))
        # overwrite
        cov[[g]] <- COV
        out <- lav_samplestats_icov(
          COV = COV,
          x.idx = x.idx[[g]],
          ngroups = ngroups, g = g
        )
        icov[[g]] <- out$icov
        cov.log.det[[g]] <- out$cov.log.det

        # the same for res.cov if conditional.x = TRUE
        if (conditional.x) {
          RES.COV <-
            cov2cor(lav_matrix_symmetric_force_pd(res.cov[[g]],
              tol = 1e-04
            ))
          # overwrite
          res.cov[[g]] <- RES.COV
          out <- lav_samplestats_icov(
            COV = RES.COV,
            ridge = 1e-05,
            x.idx = x.idx[[g]],
            ngroups = ngroups, g = g
          )
          res.icov[[g]] <- out$icov
          res.cov.log.det[[g]] <- out$cov.log.det
        }
      }
    } # categorical

    # continuous -- multilevel
    else if (nlevels > 1L) {
      # level-based sample statistics
      YLp[[g]] <- lav_samplestats_cluster_patterns(
        Y = X[[g]],
        Lp = lavdata@Lp[[g]],
        conditional.x = lavoptions$conditional.x
      )


      if (conditional.x) {
        # for starting values only
        # no handling of missing data yet....
        if (missing %in% c(
          "ml", "ml.x",
          "two.stage", "robust.two.stage"
        )) {
          lav_msg_stop(gettextf(
            "missing = %s + conditional.x + two.level not supported yet",
            missing))
        }

        # residual covariances!
        Y <- X[[g]] # contains eXo
        COV <- unname(stats::cov(Y, use = "pairwise.complete.obs"))
		# if we have missing values (missing by design?), replace them by 0
		COV[is.na(COV)] <- 0
        MEAN <- unname(colMeans(Y, na.rm = TRUE))
        var[[g]] <- diag(COV)
        # rescale cov by (N-1)/N? (only COV!)
        if (rescale) {
          # we 'transform' the sample cov (divided by n-1)
          # to a sample cov divided by 'n'
          COV <- ((nobs[[g]] - 1) / nobs[[g]]) * COV
        }
        cov[[g]] <- COV
        if (ridge) {
          diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps
          var[[g]] <- diag(cov[[g]])
        }
        mean[[g]] <- MEAN

        A <- COV[-x.idx[[g]], -x.idx[[g]], drop = FALSE]
        B <- COV[-x.idx[[g]], x.idx[[g]], drop = FALSE]
        C <- COV[x.idx[[g]], x.idx[[g]], drop = FALSE]
        # FIXME: make robust against singular C!!!
        res.cov[[g]] <- A - B %*% solve(C) %*% t(B)
        res.var[[g]] <- diag(cov[[g]])

        MY <- MEAN[-x.idx[[g]]]
        MX <- MEAN[x.idx[[g]]]
        C3 <- rbind(
          c(1, MX),
          cbind(MX, C + tcrossprod(MX))
        )
        B3 <- cbind(MY, B + tcrossprod(MY, MX))
        COEF <- unname(solve(C3, t(B3)))

        res.int[[g]] <- COEF[1, ] # intercepts
        res.slopes[[g]] <- t(COEF[-1, , drop = FALSE]) # slopes
      } else {
        # FIXME: needed?
		COV <- unname(stats::cov(X[[g]], use = "pairwise.complete.obs"))
        # if we have missing values (missing by design?), replace them by 0
        COV[is.na(COV)] <- 0
        cov[[g]] <- COV
        mean[[g]] <- unname(colMeans(X[[g]], na.rm = TRUE))
        var[[g]] <- diag(cov[[g]])

        # missing patterns
        if (missing %in% c("ml", "ml.x")) {
          missing.flag. <- TRUE
          missing.[[g]] <-
            lav_samplestats_missing_patterns(
              Y = X[[g]],
              Mp = Mp[[g]],
              wt = WT[[g]],
              Lp = lavdata@Lp[[g]]
            )
        }
      }
    } # multilevel

    # continuous -- single-level
    else {
      if (conditional.x) {
        # FIXME!
        # no correlation structures yet
        if (correlation) {
          lav_msg_stop(gettext(
            "conditional.x = TRUE is not supported (yet) for
            correlation structures."))
        }

        # FIXME!
        # no handling of missing data yet....
        if (missing %in% c(
          "ml", "ml.x",
          "two.stage", "robust.two.stage"
        )) {
          lav_msg_stop(gettextf(
            "missing = %s + conditional.x not supported yet", missing))
        }

        # residual covariances!

        Y <- cbind(X[[g]], eXo[[g]])
		COV <- unname(stats::cov(Y, use = "pairwise.complete.obs"))
        # if we have missing values (missing by design?), replace them by 0
        COV[is.na(COV)] <- 0
        MEAN <- unname(colMeans(Y, na.rm = TRUE))
        # rescale cov by (N-1)/N? (only COV!)
        if (rescale) {
          # we 'transform' the sample cov (divided by n-1)
          # to a sample cov divided by 'n'
          COV <- ((nobs[[g]] - 1) / nobs[[g]]) * COV
        }
        cov[[g]] <- COV
        var[[g]] <- diag(COV)
        if (ridge) {
          diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps
          var[[g]] <- diag(cov[[g]])
        }
        mean[[g]] <- MEAN

        A <- COV[-x.idx[[g]], -x.idx[[g]], drop = FALSE]
        B <- COV[-x.idx[[g]], x.idx[[g]], drop = FALSE]
        C <- COV[x.idx[[g]], x.idx[[g]], drop = FALSE]
        # FIXME: make robust against singular C!!!
        res.cov[[g]] <- A - B %*% solve(C) %*% t(B)
        res.var[[g]] <- diag(cov[[g]])


        MY <- MEAN[-x.idx[[g]]]
        MX <- MEAN[x.idx[[g]]]
        C3 <- rbind(
          c(1, MX),
          cbind(MX, C + tcrossprod(MX))
        )
        B3 <- cbind(MY, B + tcrossprod(MY, MX))
        COEF <- unname(solve(C3, t(B3)))

        res.int[[g]] <- COEF[1, ] # intercepts
        res.slopes[[g]] <- t(COEF[-1, , drop = FALSE]) # slopes
      } else if (missing == "two.stage" ||
        missing == "robust.two.stage") {
        missing.flag. <- FALSE # !!! just use sample statistics
        missing.[[g]] <-
          lav_samplestats_missing_patterns(
            Y = X[[g]],
            Mp = Mp[[g]],
            wt = WT[[g]]
          )
        current.warn <- lav_warn()
        if (lav_warn(lavoptions$em.h1.warn))
          on.exit(lav_warn(current.warn), TRUE)
        out <- lav_mvnorm_missing_h1_estimate_moments(
          Y = X[[g]],
          wt = WT[[g]],
          Mp = Mp[[g]], Yp = missing.[[g]],
          max.iter = lavoptions$em.h1.iter.max,
          tol = lavoptions$em.h1.tol,
        )
        lav_warn(current.warn)
        missing.h1.[[g]]$sigma <- out$Sigma
        missing.h1.[[g]]$mu <- out$Mu
        missing.h1.[[g]]$h1 <- out$fx

        # here, sample statistics == EM estimates
        cov[[g]] <- missing.h1.[[g]]$sigma
        if (ridge) {
          diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps
        }
        var[[g]] <- diag(cov[[g]])
        mean[[g]] <- missing.h1.[[g]]$mu
      } else if (missing %in% c("ml", "ml.x")) {
        missing.flag. <- TRUE
        missing.[[g]] <-
          lav_samplestats_missing_patterns(
            Y = X[[g]],
            Mp = Mp[[g]],
            wt = WT[[g]]
          )

        if (nlevels == 1L) {
          # estimate moments unrestricted model
          current.warn <- lav_warn()
          if (lav_warn(lavoptions$em.h1.warn))
            on.exit(lav_warn(current.warn), TRUE)
          # zero coverage?
          if (any(lav_matrix_vech(Mp[[g]]$coverage, diagonal = FALSE) == 0)) {
            #out <- lav_mvnorm_missing_h1_estimate_moments_chol(
            #         lavdata = lavdata, lavoptions = lavoptions, group = g)
            #missing.h1.[[g]]$sigma <- out$Sigma
            #missing.h1.[[g]]$mu <- out$Mu
            #missing.h1.[[g]]$h1 <- out$fx
          } else {
            out <- lav_mvnorm_missing_h1_estimate_moments(
              Y = X[[g]],
              wt = WT[[g]],
              Mp = Mp[[g]], Yp = missing.[[g]],
              max.iter = lavoptions$em.h1.iter.max,
              tol = lavoptions$em.h1.tol
            )
            missing.h1.[[g]]$sigma <- out$Sigma
            missing.h1.[[g]]$mu <- out$Mu
            missing.h1.[[g]]$h1 <- out$fx
          }
          lav_warn(current.warn)
        }

        if (!is.null(WT[[g]])) {
          # here, sample statistics == EM estimates
          cov[[g]] <- missing.h1.[[g]]$sigma
          if (ridge) {
            diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps
          }
          var[[g]] <- diag(cov[[g]])
          mean[[g]] <- missing.h1.[[g]]$mu
        } else {
          # NEEDED? why not just EM-based?
          COV <- unname(stats::cov(X[[g]], use = "pairwise.complete.obs"))
          # if we have missing values (missing by design?), replace them by 0
		  COV[is.na(COV)] <- 0
          cov[[g]] <- COV
          # rescale cov by (N-1)/N? (only COV!)
          if (rescale) {
            # we 'transform' the sample cov (divided by n-1)
            # to a sample cov divided by 'n'
            cov[[g]] <- ((nobs[[g]] - 1) / nobs[[g]]) * cov[[g]]
          }
          if (ridge) {
            diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps
          }
          var[[g]] <- diag(cov[[g]])
          mean[[g]] <- colMeans(X[[g]], na.rm = TRUE)
        }
      } else {
        # LISTWISE
        if (!is.null(WT[[g]])) {
          out <- stats::cov.wt(X[[g]],
            wt = WT[[g]],
            method = "ML"
          )
		  COV <- out$cov
          # if we have missing values (missing by design?), replace them by 0
          COV[is.na(COV)] <- 0
          cov[[g]] <- COV
          if (ridge) {
            diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps
          }
          var[[g]] <- diag(cov[[g]])
          mean[[g]] <- out$center
        } else if (lavoptions$sample.cov.robust) {
          # fixme: allow prob/max.it to be options
          out <- lav_cov_huber(
            Y = X[[g]], prob = 0.95,
            max.it = 200L, tol = 1e-07
          )
          cov[[g]] <- out$Sigma
          var[[g]] <- diag(cov[[g]])
          mean[[g]] <- out$Mu
        } else {
		  COV <- unname(stats::cov(X[[g]], use = "pairwise.complete.obs"))
          # if we have missing values (missing by design?), replace them by 0
          COV[is.na(COV)] <- 0
          cov[[g]] <- COV
          # rescale cov by (N-1)/N? (only COV!)
          if (rescale) {
            # we 'transform' the sample cov (divided by n-1)
            # to a sample cov divided by 'n'
            cov[[g]] <- ((nobs[[g]] - 1) / nobs[[g]]) * cov[[g]]
          }
          if (ridge) {
            diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps
          }
          var[[g]] <- diag(cov[[g]])
          mean[[g]] <- colMeans(X[[g]], na.rm = TRUE)
        }
      }

      # correlation structure?
      if (correlation) {
        cov[[g]] <- cov2cor(cov[[g]])
        var[[g]] <- rep(1, length(var[[g]]))
        if (conditional.x) {
          res.cov[[g]] <- cov2cor(res.cov[[g]])
          res.var[[g]] <- rep(1, length(res.var[[g]]))
          cov.x[[g]] <- cov2cor(cov.x[[g]])
          # FIXME: slopes? more?
        }
      }

      # icov and cov.log.det (but not if missing)
      if (sample.icov && !missing %in% c("ml", "ml.x")) {
        out <- lav_samplestats_icov(
          COV = cov[[g]], ridge = 1e-05,
          x.idx = x.idx[[g]],
          ngroups = ngroups, g = g
        )
        icov[[g]] <- out$icov
        cov.log.det[[g]] <- out$cov.log.det

        # the same for res.cov if conditional.x = TRUE
        if (conditional.x) {
          out <- lav_samplestats_icov(
            COV = res.cov[[g]],
            ridge = 1e-05,
            x.idx = x.idx[[g]],
            ngroups = ngroups, g = g
          )
          res.icov[[g]] <- out$icov
          res.cov.log.det[[g]] <- out$cov.log.det
        }
      }
    } # continuous - single level


    # WLS.obs
    if (nlevels == 1L) {
      if (estimator == "catML") {
        # correlations only (for now)
        tmp.categorical <- FALSE
        tmp.meanstructure <- FALSE
      } else {
        tmp.categorical <- categorical
        tmp.meanstructure <- meanstructure
      }
      WLS.obs[[g]] <- lav_samplestats_wls_obs(
        mean.g = mean[[g]],
        cov.g = cov[[g]], var.g = var[[g]], th.g = th[[g]],
        th.idx.g = th.idx[[g]], res.int.g = res.int[[g]],
        res.cov.g = res.cov[[g]], res.var.g = res.var[[g]],
        res.th.g = res.th[[g]], res.slopes.g = res.slopes[[g]],
        group.w.g = log(nobs[[g]]),
        categorical = tmp.categorical, conditional.x = conditional.x,
        meanstructure = tmp.meanstructure, correlation = correlation,
        slopestructure = conditional.x,
        group.w.free = group.w.free
      )
    }

    # fill in the other slots
    if (!is.null(eXo[[g]])) {
      if (!is.null(WT[[g]])) {
        if (missing != "listwise") {
          cov.x[[g]] <- missing.h1.[[g]]$sigma[x.idx[[g]],
            x.idx[[g]],
            drop = FALSE
          ]
          mean.x[[g]] <- missing.h1.[[g]]$mu[x.idx[[g]]]
        } else {
          out <- stats::cov.wt(eXo[[g]],
            wt = WT[[g]],
            method = "ML"
          )
          cov.x[[g]] <- out$cov
          mean.x[[g]] <- out$center
        }
      } else {
        cov.x[[g]] <- cov(eXo[[g]], use = "pairwise")
        if (rescale) {
          # we 'transform' the sample cov (divided by n-1)
          # to a sample cov divided by 'n'
          cov.x[[g]] <- ((nobs[[g]] - 1) / nobs[[g]]) * cov.x[[g]]
        }
        mean.x[[g]] <- colMeans(eXo[[g]])
      }
    }

    # NACOV (=GAMMA)
    if (!NACOV.user && nlevels == 1L) {
      if (estimator == "ML" && !missing.flag. && NACOV.compute) {
        if (conditional.x) {
          Y <- Y
        } else {
          Y <- X[[g]]
        }

        if (length(lavdata@cluster) > 0L) {
          cluster.idx <- lavdata@Lp[[g]]$cluster.idx[[2]]
        } else {
          cluster.idx <- NULL
        }

        if (correlation) {
		  NACOV[[g]] <- lav_samplestats_cor_Gamma(
		    Y = Y,
			meanstructure = meanstructure
		  )
		} else {
          NACOV[[g]] <-
            lav_samplestats_Gamma(
              Y = Y,
              x.idx = x.idx[[g]],
              cluster.idx = cluster.idx,
              fixed.x = fixed.x,
              conditional.x = conditional.x,
              meanstructure = meanstructure,
              slopestructure = conditional.x,
              gamma.n.minus.one =
                lavoptions$gamma.n.minus.one,
              unbiased = lavoptions$gamma.unbiased,
              Mplus.WLS = FALSE
            )
        }
      } else if (estimator %in% c("WLS", "DWLS", "ULS", "DLS", "catML")) {
        if (!categorical) {
          # sample size large enough?
          nvar <- ncol(X[[g]])
          # if(conditional.x && nexo > 0L) {
          #    nvar <- nvar - nexo
          # }
          pstar <- nvar * (nvar + 1) / 2
          if (meanstructure) pstar <- pstar + nvar
          if (conditional.x && nexo > 0L) {
            pstar <- pstar + (nvar * nexo)
          }
          if (nrow(X[[g]]) < pstar) {
            if (ngroups > 1L) {
              lav_msg_warn(gettextf(
              "number of observations (%s) too small to compute Gamma",
              nrow(X[[g]]), " in group %s", g))
            } else {
              lav_msg_warn(gettextf(
              "number of observations (%s) too small to compute Gamma",
              nrow(X[[g]])))
            }
          }
          if (conditional.x) {
            Y <- Y
          } else {
            Y <- X[[g]]
          }

          if (length(lavdata@cluster) > 0L) {
            cluster.idx <- lavdata@Lp[[g]]$cluster.idx[[2]]
          } else {
            cluster.idx <- NULL
          }
		  if (correlation) {
            NACOV[[g]] <- lav_samplestats_cor_Gamma(
              Y = Y,
              meanstructure = meanstructure
            )
		  } else {
            if (lavoptions$se == "robust.sem.nt") {
              NACOV[[g]] <-
                lav_samplestats_Gamma_NT(
                  Y = Y,
                  x.idx = x.idx[[g]],
                  # cluster.idx = cluster.idx, # not available
                  fixed.x = fixed.x,
                  conditional.x = conditional.x,
                  meanstructure = meanstructure,
                  slopestructure = conditional.x
                )
            } else {
              NACOV[[g]] <-
                lav_samplestats_Gamma(
                  Y = Y,
                  x.idx = x.idx[[g]],
                  cluster.idx = cluster.idx,
                  fixed.x = fixed.x,
                  conditional.x = conditional.x,
                  meanstructure = meanstructure,
                  slopestructure = conditional.x,
                  gamma.n.minus.one =
                    lavoptions$gamma.n.minus.one,
                  unbiased =
                    lavoptions$gamma.unbiased,
                  Mplus.WLS = lavoptions$gamma.wls.mplus
                )
            }
          }
        } else { # categorical case
          NACOV[[g]] <- CAT$WLS.W * nobs[[g]]
          if (lavoptions$gamma.n.minus.one) {
            NACOV[[g]] <- NACOV[[g]] * (nobs[[g]] / (nobs[[g]] - 1L))
          }
          if (estimator == "catML") {
            # remove all but the correlation part
            ntotal <- nrow(NACOV[[g]])
            pstar <- nrow(CAT$A22)
            nocor <- ntotal - pstar
            if (length(nocor) > 0L) {
              NACOV[[g]] <- NACOV[[g]][
                -seq_len(nocor),
                -seq_len(nocor)
              ]
            }
          }
        }
      } else if (estimator == "PML") {
        # no NACOV ... for now
      }

      # group.w.free
      if (!is.null(NACOV[[g]]) && group.w.free) {
        # unweight!!
        a <- group.w[[g]] * sum(unlist(nobs)) / nobs[[g]]
        # always 1!!!
        NACOV[[g]] <- lav_matrix_bdiag(matrix(a, 1, 1), NACOV[[g]])
      }
    }

    # WLS.V
    if (!WLS.V.user && nlevels == 1L) {
      if (estimator == "DLS" && dls.GammaNT == "sample" && dls.a < 1.0) {
        # compute GammaNT here
        if (correlation) {
          GammaNT <- lav_samplestats_cor_Gamma_NT(
            COV            = cov[[g]],
            MEAN           = mean[[g]],
            rescale        = FALSE,
            x.idx          = x.idx[[g]],     # not used yet
            fixed.x        = fixed.x,        # not used yet
            conditional.x  = conditional.x,  # not used yet
            meanstructure  = meanstructure,  # not used yet
            slopestructure = conditional.x   # not used yet
          )
        } else {
          GammaNT <- lav_samplestats_Gamma_NT(
            COV            = cov[[g]],
            MEAN           = mean[[g]],
            rescale        = FALSE,
            x.idx          = x.idx[[g]],
            fixed.x        = fixed.x,
            conditional.x  = conditional.x,
            meanstructure  = meanstructure,
            slopestructure = conditional.x
          )
        }
      }

      if (estimator == "GLS" ||
        (estimator == "DLS" && dls.GammaNT == "sample" &&
          dls.a == 1.0)) {
        # Note: we need the 'original' COV/MEAN/ICOV
        #        sample statistics; not the 'residual' version
        if (correlation) {
          GammaNT <- lav_samplestats_cor_Gamma_NT(
            COV            = cov[[g]],
            MEAN           = mean[[g]],
            #rescale        = FALSE,
            x.idx          = x.idx[[g]],     # not used yet
            fixed.x        = fixed.x,        # not used yet
            conditional.x  = conditional.x,  # not used yet
            meanstructure  = meanstructure,  # not used yet
            slopestructure = conditional.x   # not used yet
          )
          WLS.V[[g]] <- lav_matrix_symmetric_inverse(GammaNT)
        } else {
          WLS.V[[g]] <- lav_samplestats_Gamma_inverse_NT(
            ICOV           = icov[[g]],
            COV            = cov[[g]],
            MEAN           = mean[[g]],
            rescale        = FALSE,
            x.idx          = x.idx[[g]],
            fixed.x        = fixed.x,
            conditional.x  = conditional.x,
            meanstructure  = meanstructure,
            slopestructure = conditional.x
          )
        }
        if (lavoptions$gls.v11.mplus && !conditional.x && meanstructure) {
          # bug in Mplus? V11 rescaled by nobs[[g]]/(nobs[[g]]-1)
          nvar <- NCOL(cov[[g]])
          WLS.V[[g]][1:nvar, 1:nvar] <-
            WLS.V[[g]][1:nvar, 1:nvar,
              drop = FALSE
            ] * (nobs[[g]] / (nobs[[g]] - 1))
        }
      } else if (estimator == "ML") {
        # no WLS.V here, since function of model-implied moments
      } else if (estimator %in% c("WLS", "DWLS", "ULS", "DLS")) {
        if (!categorical) {
          if (estimator == "WLS" || estimator == "DLS") {
            if (!fixed.x) {
              if (estimator != "DLS") {
                # Gamma should be po before we invert
                ev <- eigen(NACOV[[g]], # symmetric=FALSE,
                  only.values = TRUE
                )$values
                if (is.complex(ev)) {
                  lav_msg_stop(gettext(
                    "Gamma (NACOV) matrix is not positive-definite"))
                }
                if (any(Re(ev) < 0)) {
                  lav_msg_stop(gettext(
                    "Gamma (NACOV) matrix is not positive-definite"))
                }
              }
              if (estimator == "DLS" && dls.GammaNT == "sample") {
                if (dls.a == 1.0) {
                  # nothing to do, use GLS version
                } else {
                  W.DLS <-
                    (1 - dls.a) * NACOV[[g]] + dls.a * GammaNT
                  WLS.V[[g]] <-
                    lav_matrix_symmetric_inverse(W.DLS)
                }
              } else { # WLS
                WLS.V[[g]] <-
                  lav_matrix_symmetric_inverse(NACOV[[g]])
              }
            } else {
              # fixed.x: we have zero cols/rows
              # ginv does the trick, but perhaps this is overkill
              # just removing the zero rows/cols, invert, and
              # fill back in the zero rows/cols would do it
              # WLS.V[[g]] <- MASS::ginv(NACOV[[g]])
              if (estimator == "DLS" && dls.GammaNT == "sample") {
                W.DLS <- (1 - dls.a) * NACOV[[g]] + dls.a * GammaNT
                WLS.V[[g]] <-
                  lav_matrix_symmetric_inverse(W.DLS)
              } else { # WLS
                WLS.V[[g]] <-
                  lav_matrix_symmetric_inverse(NACOV[[g]])
              }
            }
          } else if (estimator == "DWLS") {
            dacov <- diag(NACOV[[g]])
            if (!all(is.finite(dacov))) {
              lav_msg_stop(gettext(
                "diagonal of Gamma (NACOV) contains non finite values"))
            }
            if (fixed.x) {
              # structural zeroes!
              zero.idx <- which(dacov == 0.0)
              idacov <- 1 / dacov
              idacov[zero.idx] <- 0.0
            } else {
              idacov <- 1 / dacov
            }
            WLS.V[[g]] <- diag(idacov,
              nrow = NROW(NACOV[[g]]),
              ncol = NCOL(NACOV[[g]])
            )
            WLS.VD[[g]] <- idacov
          } else if (estimator == "ULS") {
            # WLS.V[[g]] <- diag(length(WLS.obs[[g]]))
            WLS.VD[[g]] <- rep(1, length(WLS.obs[[g]]))
          }
        } else {
          if (estimator == "WLS") {
            cS <- tryCatch(chol(CAT$WLS.W * nobs[[g]]),
                           error = function(e) NULL)
            if (is.null(cS)) {
              lav_msg_stop(gettext("could not invert CAT$WLS.W"))
            }
            WLS.V[[g]] <- chol2inv(cS)
          } else if (estimator == "DWLS") {
            dacov <- diag(CAT$WLS.W * nobs[[g]])
            # WLS.V[[g]] <- diag(1/dacov, nrow=NROW(CAT$WLS.W),
            #                            ncol=NCOL(CAT$WLS.W))
            WLS.VD[[g]] <- 1 / dacov
          } else if (estimator == "ULS") {
            # WLS.V[[g]] <- diag(length(WLS.obs[[g]]))
            WLS.VD[[g]] <- rep(1, length(WLS.obs[[g]]))
          }
        }
      } else if (estimator == "PML" || estimator == "FML") {
        # no WLS.V here
      }

      # group.w.free (only if categorical)
      if (group.w.free && categorical) {
        if (!is.null(WLS.V[[g]])) {
          # unweight!!
          a <- group.w[[g]] * sum(unlist(nobs)) / nobs[[g]]
          # always 1!!!
          # invert
          a <- 1 / a
          WLS.V[[g]] <- lav_matrix_bdiag(matrix(a, 1, 1), WLS.V[[g]])
        }
        if (!is.null(WLS.VD[[g]])) {
          # unweight!!
          a <- group.w[[g]] * sum(unlist(nobs)) / nobs[[g]]
          # always 1!!!
          # invert
          a <- 1 / a
          WLS.VD[[g]] <- c(a, WLS.VD[[g]])
        }
      }
    }
  } # ngroups

  # remove 'CAT', unless debug -- this is to save memory
  if (!lav_debug()) {
    CAT <- list()
  }

  # construct SampleStats object
  lavSampleStats <- new("lavSampleStats",
    # sample moments
    th = th,
    th.idx = th.idx,
    th.names = th.names,
    mean = mean,
    cov = cov,
    var = var,

    # residual (y | x)
    res.cov = res.cov,
    res.var = res.var,
    res.th = res.th,
    res.th.nox = res.th.nox,
    res.slopes = res.slopes,
    res.int = res.int,
    mean.x = mean.x,
    cov.x = cov.x,
    bifreq = bifreq,
    group.w = group.w,

    # convenience
    nobs = nobs,
    ntotal = sum(unlist(nobs)),
    ngroups = ngroups,
    x.idx = x.idx,

    # extra sample statistics
    icov = icov,
    cov.log.det = cov.log.det,
    res.icov = res.icov,
    res.cov.log.det = res.cov.log.det,
    ridge = ridge.eps,
    WLS.obs = WLS.obs,
    WLS.V = WLS.V,
    WLS.VD = WLS.VD,
    NACOV = NACOV,
    NACOV.user = NACOV.user,

    # cluster/levels
    YLp = YLp,

    # missingness
    missing.flag = missing.flag.,
    missing = missing.,
    missing.h1 = missing.h1.,
    zero.cell.tables = zero.cell.tables
  )

  # just a SINGLE warning if we have empty cells
  if ((!is.null(lavoptions$samplestats) && lavoptions$samplestats) &&
      categorical && zero.cell.warn &&
      any(sapply(zero.cell.tables, nrow) > 0L)) {
    nempty <- sum(sapply(zero.cell.tables, nrow))
    lav_msg_warn(gettextf(
      "%s bivariate tables have empty cells; to see them, use:
      lavInspect(fit, \"zero.cell.tables\")", nempty)
    )
  }

  lavSampleStats
}


lav_samplestats_from_moments <- function(sample.cov = NULL,
                                         sample.mean = NULL,
                                         sample.th = NULL,
                                         sample.nobs = NULL,
                                         ov.names = NULL, # including x
                                         ov.names.x = NULL,
                                         WLS.V = NULL,
                                         NACOV = NULL,
                                         lavoptions = NULL) {
  # extract options
  estimator <- lavoptions$estimator
  mimic <- lavoptions$mimic
  meanstructure <- lavoptions$meanstructure
  correlation <- lavoptions$correlation
  group.w.free <- lavoptions$group.w.free
  ridge <- lavoptions$ridge
  rescale <- lavoptions$sample.cov.rescale

  # no multilevel yet
  nlevels <- 1L

  # ridge default
  if (ridge) {
    if (is.numeric(lavoptions$ridge.constant)) {
      ridge.eps <- lavoptions$ridge.constant
    } else {
      ridge.eps <- 1e-5
    }
  } else {
    ridge.eps <- 0.0
  }

  # new in 0.6-3:
  # check if sample.cov has attributes if conditional.x = TRUE
  sample.res.slopes <- attr(sample.cov, "res.slopes")
  sample.cov.x <- attr(sample.cov, "cov.x")
  sample.mean.x <- attr(sample.cov, "mean.x")
  if (!is.null(sample.res.slopes)) {
    conditional.x <- TRUE
    # strip attributes
    attr(sample.cov, "res.slopes") <- NULL
    attr(sample.cov, "cov.x") <- NULL
    attr(sample.cov, "mean.x") <- NULL
    # make list
    if (!is.list(sample.res.slopes)) {
      sample.res.slopes <- list(sample.res.slopes)
    }
    if (!is.list(sample.cov.x)) {
      sample.cov.x <- list(sample.cov.x)
    }
    if (!is.list(sample.mean.x)) {
      sample.mean.x <- list(sample.mean.x)
    }
  } else if (!is.null(sample.cov.x)) {
    conditional.x <- FALSE
    fixed.x <- TRUE

    # strip attributes
    attr(sample.cov, "cov.x") <- NULL
    attr(sample.cov, "mean.x") <- NULL
    # make list
    if (!is.list(sample.cov.x)) {
      sample.cov.x <- list(sample.cov.x)
    }
    if (!is.list(sample.mean.x)) {
      sample.mean.x <- list(sample.mean.x)
    }
  } else if (is.null(sample.cov.x) && length(unlist(ov.names.x)) > 0L) {
    # fixed.x = TRUE, but only joint sample.cov is provided
    conditional.x <- FALSE
    fixed.x <- TRUE

    # create sample.cov.x and sample.mean.x later...
  } else {
    conditional.x <- FALSE
    fixed.x <- FALSE
  }

  # matrix -> list
  if (!is.list(sample.cov)) {
    sample.cov <- list(sample.cov)
  }

  # number of groups
  ngroups <- length(sample.cov)

  # ov.names
  if (!is.list(ov.names)) {
    ov.names <- rep(list(ov.names), ngroups)
  }
  if (!is.list(ov.names.x)) {
    ov.names.x <- rep(list(ov.names.x), ngroups)
  }

  if (!is.null(sample.mean)) {
    meanstructure <- TRUE
    if (!is.list(sample.mean)) {
      # check if sample.mean is string (between single quotes)
      if (is.character(sample.mean)) {
        sample.mean <- lav_char2num(sample.mean)
      }
      sample.mean <- list(unname(sample.mean))
    } else {
      sample.mean <- lapply(lapply(sample.mean, unname), unclass)
    }
  }

  if (!is.null(sample.th)) {
    th.idx <- attr(sample.th, "th.idx")
    attr(sample.th, "th.idx") <- NULL
    if (is.null(th.idx)) {
      lav_msg_stop(gettext("sample.th should have a th.idx attribute"))
    } else {
      if (is.list(th.idx)) {
        th.names <- lapply(th.idx, names)
        th.idx <- lapply(lapply(th.idx, unname), unclass)
      } else {
        th.names <- list(names(th.idx))
        th.idx <- list(unclass(unname(th.idx)))
      }
    }
    if (is.list(sample.th)) {
      # strip names and lavaan.vector class
      sample.th <- lapply(lapply(sample.th, unname), unclass)
    } else {
      # strip names and lavaan.vector class, make list
      sample.th <- list(unclass(unname(sample.th)))
    }
  } else {
    th.idx <- vector("list", length = ngroups)
    th.names <- vector("list", length = ngroups)
  }

  # sample statistics per group
  cov <- vector("list", length = ngroups)
  var <- vector("list", length = ngroups)
  mean <- vector("list", length = ngroups)
  th <- vector("list", length = ngroups)
  # th.idx      <- vector("list", length = ngroups)
  # th.names    <- vector("list", length = ngroups)

  # residual (y | x)
  res.cov <- vector("list", length = ngroups)
  res.var <- vector("list", length = ngroups)
  res.slopes <- vector("list", length = ngroups)
  res.int <- vector("list", length = ngroups)
  res.th <- vector("list", length = ngroups)
  res.th.nox <- vector("list", length = ngroups)

  # fixed.x / conditional.x
  mean.x <- vector("list", length = ngroups)
  cov.x <- vector("list", length = ngroups)

  bifreq <- vector("list", length = ngroups)

  # extra sample statistics per group
  icov <- vector("list", length = ngroups)
  cov.log.det <- vector("list", length = ngroups)
  res.icov <- vector("list", length = ngroups)
  res.cov.log.det <- vector("list", length = ngroups)
  WLS.obs <- vector("list", length = ngroups)
  missing. <- vector("list", length = ngroups)
  missing.h1. <- vector("list", length = ngroups)
  missing.flag. <- FALSE
  zero.cell.tables <- vector("list", length = ngroups)
  YLp <- vector("list", length = ngroups)

  # group weights
  group.w <- vector("list", length = ngroups)
  x.idx <- vector("list", length = ngroups)

  categorical <- FALSE
  if (!is.null(sample.th)) {
    categorical <- TRUE
  }

  WLS.VD <- vector("list", length = ngroups)
  if (is.null(WLS.V)) {
    WLS.V <- vector("list", length = ngroups)
    WLS.V.user <- FALSE
  } else {
    if (!is.list(WLS.V)) {
      if (ngroups == 1L) {
        WLS.V <- list(unclass(WLS.V))
      } else {
        lav_msg_stop(gettextf("WLS.V argument should be a list of length %s",
          ngroups)
        )
      }
    } else {
      if (length(WLS.V) != ngroups) {
        lav_msg_stop(gettextf(
          "WLS.V assumes %1$s groups; data contains %2$s groups",
          length(WLS.V), ngroups))
      }
      WLS.V <- lapply(WLS.V, unclass)
    }

    # is WLS.V full? check first
    if (is.null(dim(WLS.V[[1]]))) {
      # we will assume it is the diagonal only
      WLS.VD <- WLS.V
      WLS.V <- lapply(WLS.VD, diag)
    } else {
      # create WLS.VD
      WLS.VD <- lapply(WLS.V, diag)
      # we could remove WLS.V to save space...
    }

    WLS.V.user <- TRUE
    # FIXME: check dimension of WLS.V!!
  }

  if (is.null(NACOV)) {
    NACOV <- vector("list", length = ngroups)
    NACOV.user <- FALSE
  } else {
    if (!is.list(NACOV)) {
      if (ngroups == 1L) {
        NACOV <- list(unclass(NACOV))
      } else {
        lav_msg_stop(gettextf(
          "NACOV argument should be a list of length %s", ngroups))
      }
    } else {
      if (length(NACOV) != ngroups) {
        lav_msg_stop(gettextf(
          "NACOV assumes %1$s groups; data contains %2$s groups",
          length(NACOV), ngroups))
      }
      NACOV <- lapply(NACOV, unclass)
    }
    NACOV.user <- TRUE
    # FIXME: check dimension of NACOV!!
  }

  nobs <- as.list(as.integer(sample.nobs))


  for (g in 1:ngroups) {
    # exogenous x?
    nexo <- length(ov.names.x[[g]])
    if (nexo) {
      # two cases: ov.names contains 'x' variables, or not
      if (conditional.x) {
        # ov.names.x are NOT in ov.names
        x.idx[[g]] <- which(ov.names[[g]] %in% ov.names.x[[g]])
      } else {
        if (fixed.x) {
          # ov.names.x are a subset of ov.names
          x.idx[[g]] <- match(ov.names.x[[g]], ov.names[[g]])
          stopifnot(!anyNA(x.idx[[g]]))
        } else {
          x.idx[[g]] <- integer(0L)
        }
      }
    } else {
      x.idx[[g]] <- integer(0L)
      conditional.x <- FALSE
      fixed.x <- FALSE
    }


    # group weight
    group.w[[g]] <- nobs[[g]] / sum(unlist(nobs))

    tmp.cov <- sample.cov[[g]]

    # make sure that the matrix is fully symmetric (NEEDED?)
    T <- t(tmp.cov)
    tmp.cov[upper.tri(tmp.cov)] <- T[upper.tri(T)]

    # check dimnames
    if (!is.null(rownames(tmp.cov))) {
      cov.names <- rownames(tmp.cov)
    } else if (!is.null(colnames(tmp.cov))) {
      cov.names <- colnames(tmp.cov)
    } else {
      lav_msg_stop(gettext(
        "please provide row/col names for the covariance matrix!"))
    }

    # extract only the part we need (using ov.names)
    if (conditional.x) {
      idx <- match(ov.names[[g]][-x.idx[[g]]], cov.names)
    } else {
      idx <- match(ov.names[[g]], cov.names)
    }
    if (any(is.na(idx))) {
      cat("found: ", cov.names, "\n")
      cat("expected: ", ov.names[[g]], "\n")
      lav_msg_stop(gettextf(
        "rownames of covariance matrix do not match the model!
        found: %1$s expected: %2$s", lav_msg_view(cov.names),
        lav_msg_view(ov.names[[g]])))
    } else {
      tmp.cov <- tmp.cov[idx, idx, drop = FALSE]
    }

    # strip dimnames
    dimnames(tmp.cov) <- NULL

    if (is.null(sample.mean)) {
      # assume zero mean vector
      tmp.mean <- numeric(ncol(tmp.cov))
    } else {
      # extract only the part we need
      tmp.mean <- unclass(sample.mean[[g]][idx])
    }



    if (categorical) {
      # categorical + conditional.x = TRUE
      if (conditional.x) {
        th.g <- numeric(length(th.idx[[g]]))
        ord.idx <- which(th.idx[[g]] > 0)
        num.idx <- which(th.idx[[g]] == 0)
        if (length(ord.idx) > 0L) {
          th.g[ord.idx] <- sample.th[[g]][ord.idx]
        }
        if (length(num.idx) > 0L) {
          ord.var.idx <- unique(th.idx[[g]][th.idx[[g]] > 0])
          th.g[num.idx] <- -1 * sample.mean[[g]][-ord.var.idx]
        }
        res.th[[g]] <- th.g
        res.th.nox[[g]] <- sample.th[[g]]

        res.cov[[g]] <- tmp.cov
        if (ridge) {
          diag(res.cov[[g]]) <- diag(res.cov[[g]]) + ridge.eps
        }
        res.var[[g]] <- diag(tmp.cov)
        res.int[[g]] <- tmp.mean

        res.slopes[[g]] <- unclass(unname(sample.res.slopes[[g]]))
        cov.x[[g]] <- unclass(unname(sample.cov.x[[g]]))
        mean.x[[g]] <- unclass(unname(sample.mean.x[[g]]))

        # th.idx and th.names are already ok

        # categorical + conditional.x = FALSE
      } else {
        th.g <- numeric(length(th.idx[[g]]))
        ord.idx <- which(th.idx[[g]] > 0)
        num.idx <- which(th.idx[[g]] == 0)
        if (length(ord.idx) > 0L) {
          th.g[ord.idx] <- sample.th[[g]][ord.idx]
        }
        if (length(num.idx) > 0L) {
          ord.var.idx <- unique(th.idx[[g]][th.idx[[g]] > 0])
          th.g[num.idx] <- -1 * sample.mean[[g]][-ord.var.idx]
        }
        th[[g]] <- th.g

        cov[[g]] <- tmp.cov
        if (ridge) {
          diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps
        }
        var[[g]] <- diag(tmp.cov)
        mean[[g]] <- tmp.mean

        # fixed.x? (needed?)
        if (fixed.x) {
          cov.x[[g]] <- unclass(unname(sample.cov.x[[g]]))
          mean.x[[g]] <- unclass(unname(sample.mean.x[[g]]))
        }

        # th, th.idx and th.names are already ok
      }

      # multilevel
    } else if (nlevels > 1L) {
      lav_msg_stop(gettext("multilevel + sample stats not ready yet"))


      # single level
    } else {
      # single-level + continuous + conditional.x = TRUE
      if (conditional.x) {
        res.cov[[g]] <- tmp.cov
        if (ridge) {
          diag(res.cov[[g]]) <- diag(res.cov[[g]]) + ridge.eps
        }
        res.var[[g]] <- diag(tmp.cov)
        res.int[[g]] <- tmp.mean
        res.slopes[[g]] <- unclass(unname(sample.res.slopes[[g]]))
        cov.x[[g]] <- unclass(unname(sample.cov.x[[g]]))
        mean.x[[g]] <- unclass(unname(sample.mean.x[[g]]))

        # no rescale!

        # icov and cov.log.det
        # if(lavoptions$sample.icov) {
        out <- lav_samplestats_icov(
          COV = res.cov[[g]],
          ridge = 1e-05,
          x.idx = x.idx[[g]],
          ngroups = ngroups, g = g
        )
        res.icov[[g]] <- out$icov
        res.cov.log.det[[g]] <- out$cov.log.det
        # }

        # continuous + conditional.x = FALSE
      } else {
        cov[[g]] <- tmp.cov
        mean[[g]] <- tmp.mean

        # rescale cov by (N-1)/N?
        if (rescale) {
          # we 'transform' the sample cov (divided by n-1)
          # to a sample cov divided by 'n'
          cov[[g]] <- ((nobs[[g]] - 1) / nobs[[g]]) * cov[[g]]
        }
        if (ridge) {
          diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps
        }
        var[[g]] <- diag(cov[[g]])

        # icov and cov.log.det
        # if(lavoptions$sample.icov) {
        out <- lav_samplestats_icov(
          COV = cov[[g]],
          ridge = 1e-05,
          x.idx = x.idx[[g]],
          ngroups = ngroups,
          g = g
        )
        icov[[g]] <- out$icov
        cov.log.det[[g]] <- out$cov.log.det
        # }

        # fixed.x?
        if (fixed.x) {
          if (is.null(sample.cov.x)) {
            cov.x[[g]] <- cov[[g]][x.idx[[g]], x.idx[[g]],
              drop = FALSE
            ]
          } else {
            cov.x[[g]] <- unclass(unname(sample.cov.x[[g]]))
          }
          if (is.null(sample.mean.x)) {
            mean.x[[g]] <- mean[[g]][x.idx[[g]]]
          } else {
            mean.x[[g]] <- unclass(unname(sample.mean.x[[g]]))
          }
        }
      }

      # correlation structure?
      if (correlation) {
        cov[[g]] <- cov2cor(cov[[g]])
        var[[g]] <- rep(1, length(var[[g]]))
        if (conditional.x) {
          res.cov[[g]] <- cov2cor(res.cov[[g]])
          res.var[[g]] <- rep(1, length(res.var[[g]]))
          cov.x[[g]] <- cov2cor(cov.x[[g]])
          # FIXME: slopes? more?
        }
      }
    }

    # WLS.obs
    WLS.obs[[g]] <- lav_samplestats_wls_obs(
      mean.g = mean[[g]],
      cov.g = cov[[g]], var.g = var[[g]], th.g = th[[g]],
      th.idx.g = th.idx[[g]], res.int.g = res.int[[g]],
      res.cov.g = res.cov[[g]], res.var.g = res.var[[g]],
      res.th.g = res.th[[g]], res.slopes.g = res.slopes[[g]],
      group.w.g = log(nobs[[g]]),
      categorical = categorical, conditional.x = conditional.x,
      meanstructure = meanstructure, correlation = correlation,
      slopestructure = conditional.x,
      group.w.free = group.w.free
    )

    # WLS.V
    if (!WLS.V.user) {
      if (estimator == "GLS") {
        # FIXME: in <0.5-21, we had
        # V11 <- icov[[g]]
        #    if(mimic == "Mplus") { # is this a bug in Mplus?
        #        V11 <- V11 * nobs[[g]]/(nobs[[g]]-1)
        #    }
        if (correlation) {
          GammaNT <- lav_samplestats_cor_Gamma_NT(
            COV            = cov[[g]],
            MEAN           = mean[[g]],
            #rescale        = FALSE,
            x.idx          = x.idx[[g]],     # not used yet
            fixed.x        = fixed.x,        # not used yet
            conditional.x  = conditional.x,  # not used yet
            meanstructure  = meanstructure,  # not used yet
            slopestructure = conditional.x   # not used yet
          )
          WLS.V[[g]] <- lav_matrix_symmetric_inverse(GammaNT)
        } else {
          WLS.V[[g]] <- lav_samplestats_Gamma_inverse_NT(
            ICOV = icov[[g]],
            COV = cov[[g]],
            MEAN = mean[[g]],
            rescale = FALSE,
            x.idx = x.idx[[g]],
            fixed.x = fixed.x,
            conditional.x = conditional.x,
            meanstructure = meanstructure,
            slopestructure = conditional.x
          )
        }
      } else if (estimator == "ULS") {
        WLS.V[[g]] <- diag(length(WLS.obs[[g]]))
        WLS.VD[[g]] <- rep(1, length(WLS.obs[[g]]))
      } else if (estimator == "WLS" || estimator == "DWLS") {
        if (is.null(WLS.V[[g]])) {
          lav_msg_stop(gettext(
            "the (D)WLS estimator is only available with full data
            or with a user-provided WLS.V"))
        }
      }

      # group.w.free
      if (!is.null(WLS.V[[g]]) && group.w.free) {
        # FIXME!!!
        WLS.V[[g]] <- lav_matrix_bdiag(matrix(1, 1, 1), WLS.V[[g]])
      }
    }
  } # ngroups

  # construct SampleStats object
  lavSampleStats <- new("lavSampleStats",
    # sample moments
    th = th,
    th.idx = th.idx,
    th.names = th.names,
    mean = mean,
    cov = cov,
    var = var,

    # residual (y | x)
    res.cov = res.cov,
    res.var = res.var,
    res.th = res.th,
    res.th.nox = res.th.nox,
    res.slopes = res.slopes,
    res.int = res.int,

    # fixed.x
    mean.x = mean.x,
    cov.x = cov.x,

    # other
    bifreq = bifreq,
    group.w = group.w,

    # convenience
    nobs = nobs,
    ntotal = sum(unlist(nobs)),
    ngroups = ngroups,
    x.idx = x.idx,

    # extra sample statistics
    icov = icov,
    cov.log.det = cov.log.det,
    res.icov = res.icov,
    res.cov.log.det = res.cov.log.det,
    ridge = ridge.eps,
    WLS.obs = WLS.obs,
    WLS.V = WLS.V,
    WLS.VD = WLS.VD,
    NACOV = NACOV,
    NACOV.user = NACOV.user,

    # cluster/level
    YLp = YLp,

    # missingness
    missing.flag = missing.flag.,
    missing = missing.,
    missing.h1 = missing.h1.,
    zero.cell.tables = zero.cell.tables
  )

  lavSampleStats
}

# compute sample statistics, per missing pattern
lav_samplestats_missing_patterns <- function(Y = NULL, Mp = NULL, wt = NULL,
                                             Lp = NULL) {
  # coerce Y to matrix
  Y <- as.matrix(Y)

  # handle two-level data
  if (!is.null(Lp)) {
    Y.orig <- Y
    Z <- NULL
    if (length(Lp$between.idx[[2]]) > 0L) {
      Y <- Y[, -Lp$between.idx[[2]], drop = FALSE]
      z.idx <- which(!duplicated(Lp$cluster.idx[[2]]))
      Z <- Y.orig[z.idx, Lp$between.idx[[2]], drop = FALSE]
    }
  }

  if (is.null(Mp)) {
    Mp <- lav_data_missing_patterns(Y,
      sort.freq = FALSE, coverage = FALSE,
      Lp = Lp
    )
  }

  Yp <- vector("list", length = Mp$npatterns)

  # fill in pattern statistics
  for (p in seq_len(Mp$npatterns)) {
    # extract raw data for these cases
    RAW <- Y[Mp$case.idx[[p]], Mp$pat[p, ], drop = FALSE]

    # more than one case
    if (Mp$freq[p] > 1L) {
      if (!is.null(wt)) {
        out <- stats::cov.wt(RAW,
          wt = wt[Mp$case.idx[[p]]],
          method = "ML"
        )
        SY <- out$cov
        MY <- out$center
      } else {
        MY <- base::.colMeans(RAW, m = NROW(RAW), n = NCOL(RAW))
        # SY <- crossprod(RAW)/Mp$freq[p] - tcrossprod(MY)
        # bad practice, better like this:
        SY <- lav_matrix_cov(RAW)
      }
    }
    # only a single observation (no need to weight!)
    else {
      SY <- 0
      MY <- as.numeric(RAW)
    }

    if (!is.null(wt)) {
      FREQ <- sum(wt[Mp$case.idx[[p]]])
    } else {
      FREQ <- Mp$freq[p]
    }

    # store sample statistics, var.idx and freq
    Yp[[p]] <- list(
      SY = SY, MY = MY, var.idx = Mp$pat[p, ],
      freq = FREQ
    )

    # if clustered data, add rowsum over all cases per cluster
    if (!is.null(Lp)) {
      tmp <- rowsum.default(RAW, group = Mp$j.idx[[p]], reorder = FALSE)
      Yp[[p]]$ROWSUM <- tmp
    }
  }

  # add Zp as an attribute
  # if(!is.null(Lp)) {
  #    Zp <- lav_samplestats_missing_patterns(Y = Z, Mp = Mp$Zp)
  #    for(p in Mp$Zp$npatterns) {
  #        this.z <- Z[Mp$Zp$case.idx[[p]], drop = FALSE]
  #        Zp[[p]]$ROWSUM <- t(this.z)
  #
  #    }
  #    attr(Yp, "Zp") <- Zp
  # }

  Yp
}

# compute sample statistics, per cluster
lav_samplestats_cluster_patterns <- function(Y = NULL, Lp = NULL,
                                             conditional.x = FALSE) {
  # coerce Y to matrix
  Y1 <- as.matrix(Y)
  N <- NROW(Y1)
  P <- NCOL(Y1)

  if (is.null(Lp)) {
    lav_msg_stop(gettext("Lp is NULL"))
  }

  # how many levels?
  nlevels <- length(Lp$cluster) + 1L

  # compute some sample statistics per level
  YLp <- vector("list", length = nlevels)
  for (l in 2:nlevels) {
    ncluster.sizes <- Lp$ncluster.sizes[[l]]
    cluster.size <- Lp$cluster.size[[l]]
    cluster.sizes <- Lp$cluster.sizes[[l]]
    nclusters <- Lp$nclusters[[l]]
    both.idx <- Lp$both.idx[[l]]
    within.idx <- Lp$within.idx[[l]]
    between.idx <- Lp$between.idx[[l]]
    cluster.idx <- Lp$cluster.idx[[l]]
    cluster.size.ns <- Lp$cluster.size.ns[[l]]

    # s <- (N^2 - sum(cluster.size^2)) / (N*(nclusters - 1L))
    # same as
    s <- (N - sum(cluster.size^2) / N) / (nclusters - 1)
    # NOTE: must be (nclusters - 1), otherwise, s is not average cluster
    # size even in the balanced case

    Y1.means <- colMeans(Y1, na.rm = TRUE)
    Y1Y1 <- lav_matrix_crossprod(Y1)
    both.idx <- all.idx <- seq_len(P)

    if (length(within.idx) > 0L ||
      length(between.idx) > 0L) {
      both.idx <- all.idx[-c(within.idx, between.idx)]
      # hm, this assumes the 'order' is the
      # same at both levels...
    }

    # cluster-means
    Y2 <- rowsum.default(Y1,
      group = cluster.idx, reorder = FALSE,
      na.rm = FALSE, # must be FALSE!
    ) / cluster.size
    Y2c <- t(t(Y2) - Y1.means)

    # compute S.w
    # center within variables by grand mean instead of group mean?
    # (YR: apparently not for S.PW)

    Y2a <- Y2
    # if(length(within.idx) > 0L) {
    #    for(i in 1:length(within.idx)) {
    #        Y2a[, within.idx[i]] <- Y1.means[within.idx[i]]
    #    }
    # }
    Y1a <- Y1 - Y2a[cluster.idx, , drop = FALSE]
    S.w <- lav_matrix_crossprod(Y1a) / (N - nclusters)

    # S.b
    # three parts: within/within, between/between, between/within
    # standard definition of the between variance matrix
    # divides by (nclusters - 1)
    S.b <- lav_matrix_crossprod(Y2c * cluster.size, Y2c) / (nclusters - 1)

    # check for zero variances
    if (length(both.idx) > 0L) {
      zero.idx <- which(diag(S.b)[both.idx] < 0.0001)
      if (length(zero.idx) > 0L && !anyNA(Y2)) {
        lav_msg_warn(gettext(
          "(near) zero variance at between level for splitted variable:"),
          paste(Lp$both.names[[l]][zero.idx], collapse = " ")
        )
      }
    }

    S <- cov(Y1, use = "pairwise.complete.obs") * (N - 1L) / N
	# missing by design?
	S[is.na(S)] <- as.numeric(NA)

    # loglik.x
    # extract 'fixed' level-1 loglik from here
    wx.idx <- Lp$ov.x.idx[[1]]
    if (length(wx.idx) > 0L) {
      loglik.x.w <- lav_mvnorm_h1_loglik_samplestats(
        sample.nobs = Lp$nclusters[[1]],
        sample.cov  = S[wx.idx, wx.idx, drop = FALSE]
      )
    } else {
      loglik.x.w <- 0
    }
    # extract 'fixed' level-2 loglik
    bx.idx <- Lp$ov.x.idx[[2]]
    if (length(bx.idx) > 0L) {
      COVB <- cov(Y2[, bx.idx, drop = FALSE]) * (nclusters - 1) / nclusters
      loglik.x.b <- lav_mvnorm_h1_loglik_samplestats(
        sample.nobs = Lp$nclusters[[2]],
        sample.cov  = COVB
      )
    } else {
      loglik.x.b <- 0
    }
    loglik.x <- loglik.x.w + loglik.x.b


    S.PW.start <- S.w
    if (length(within.idx) > 0L) {
      S.PW.start[within.idx, within.idx] <-
        S[within.idx, within.idx, drop = FALSE]
    }

    if (length(between.idx) > 0L) {
      S.w[between.idx, ] <- 0
      S.w[, between.idx] <- 0
      S.PW.start[between.idx, ] <- 0
      S.PW.start[, between.idx] <- 0
    }

    if (length(between.idx) > 0L) {
      # this is what is needed for MUML:
      S.b[, between.idx] <-
        (s * nclusters / N) * S.b[, between.idx, drop = FALSE]
      S.b[between.idx, ] <-
        (s * nclusters / N) * S.b[between.idx, , drop = FALSE]
      S.b[between.idx, between.idx] <-
        (s * lav_matrix_crossprod(
          Y2c[, between.idx, drop = FALSE],
          Y2c[, between.idx, drop = FALSE]
        ) / nclusters)
    }

    Sigma.B <- (S.b - S.w) / s
    Sigma.B[within.idx, ] <- 0
    Sigma.B[, within.idx] <- 0

    # what if we have negative variances in Sigma.B?
    # this may happen if 'split' a variable that has no between variance
    zero.idx <- which(diag(Sigma.B) < 1e-10)
    if (length(zero.idx) > 0L) {
      Sigma.B[zero.idx, ] <- 0
      Sigma.B[, zero.idx] <- 0
    }


    Mu.W <- numeric(P)
    Mu.W[within.idx] <- Y1.means[within.idx]

    Mu.B <- Y1.means
    Mu.B[within.idx] <- 0
    if (length(between.idx) > 0L) {
      # replace between.idx by cov(Y2)[,] elements...
      Mu.B[between.idx] <- colMeans(Y2[, between.idx, drop = FALSE],
        na.rm = TRUE
      )

      S2 <- (cov(Y2, use = "pairwise.complete.obs") *
        (nclusters - 1L) / nclusters)

      Sigma.B[between.idx, between.idx] <-
        S2[between.idx, between.idx, drop = FALSE]
    }

    # FIXME: Mu.B not quite ok for (fixed.x) x variables if they
    # occur both at level 1 AND level 2
    Mu.B.start <- Mu.B
    # Mu.B.start[both.idx] <- Mu.B.start[both.idx] - colMeans(Y2c[,both.idx])

    # sample statistics PER CLUSTER-SIZE

    # summary statistics for complete data, conditional.x = FALSE
    # also needed for h1 (even if conditional.x = TRUE)
    cov.d <- vector("list", length = ncluster.sizes)
    mean.d <- vector("list", length = ncluster.sizes)
    for (clz in seq_len(ncluster.sizes)) {
      nj <- cluster.sizes[clz]
      # select clusters with this size
      d.idx <- which(cluster.size == nj)
      ns <- length(d.idx)
      # NOTE:!!!!
      # reorder columns
      # to match A.inv and m.k later on in objective!!!
      tmp2 <- Y2[d.idx,
        c(between.idx, sort.int(c(both.idx, within.idx))),
        drop = FALSE
      ]
      mean.d[[clz]] <- colMeans(tmp2, na.rm = TRUE)
      bad.idx <- which(!is.finite(mean.d[[clz]])) # if nrow = 1 + NA
      if (length(bad.idx) > 0L) {
        mean.d[[clz]][bad.idx] <- 0 # ugly, only for starting values
      }
      if (length(d.idx) > 1L) {
        if (any(is.na(tmp2))) {
          # if full column has NA, this will fail...
          # not needed anyway
          # out <- lav_mvnorm_missing_h1_estimate_moments(Y = tmp2,
          #          max.iter = 10L)
          # cov.d[[clz]] <- out$Sigma
          cov.d[[clz]] <- 0
        } else {
          cov.d[[clz]] <- (cov(tmp2, use = "complete.obs") *
            (ns - 1) / ns)
        }
      } else {
        cov.d[[clz]] <- 0
      }
    } # clz

    # new in 0.6-12:
    # summary statistics for complete data, conditional.x = TRUE
    # ONLY for twolevel
    if (conditional.x) {
      within.x.idx <- Lp$within.x.idx[[1]]
      between.y.idx <- Lp$between.y.idx[[2]]
      between.x.idx <- Lp$between.x.idx[[2]]
      y1.idx <- Lp$ov.y.idx[[1]]
      x1.idx <- c(within.x.idx, between.x.idx) # in that order

      # data
      Y1.wb <- Y1[, y1.idx, drop = FALSE]
      Y2.wb <- Y2[, y1.idx, drop = FALSE]
      if (length(between.y.idx) > 0L) {
        Y2.z <- Y2[, between.y.idx, drop = FALSE]
      }
      if (length(x1.idx) > 0L) {
        EXO.wb1 <- cbind(1, Y1[, x1.idx, drop = FALSE])
        EXO.wb2 <- cbind(1, Y2[, x1.idx, drop = FALSE])
      } else {
        EXO.wb1 <- matrix(1, nrow(Y1), 1L)
        EXO.wb2 <- matrix(1, nrow(Y2), 1L)
      }

      # sample beta.wb (level 1)
      sample.wb <- solve(crossprod(EXO.wb1), crossprod(EXO.wb1, Y1.wb))
      sample.yhat.wb1 <- EXO.wb1 %*% sample.wb
      sample.yres.wb1 <- Y1.wb - sample.yhat.wb1
      sample.YYres.wb1 <- crossprod(sample.yres.wb1)
      sample.XX.wb1 <- crossprod(EXO.wb1)

      # sample beta.wb (level 2)
      XX.wb2 <- crossprod(EXO.wb2)
      sample.wb2 <- try(solve(XX.wb2, crossprod(EXO.wb2, Y2.wb)),
        silent = TRUE
      )
      if (inherits(sample.wb2, "try-error")) {
        # this may happen if the covariate is cluster-centered
        # using the observed cluster means; then the 'means' will
        # be all (near) zero, and there is no variance
        sample.wb2 <- MASS::ginv(XX.wb2) %*% crossprod(EXO.wb2, Y2.wb)
      }
      sample.yhat.wb2 <- EXO.wb2 %*% sample.wb2
      sample.yres.wb2 <- Y2.wb - sample.yhat.wb2

      # weighted by cluster.size
      sample.YYres.wb2 <- crossprod(
        sample.yres.wb2,
        sample.yres.wb2 * cluster.size
      )
      sample.YresX.wb2 <- crossprod(
        sample.yres.wb2,
        EXO.wb2 * cluster.size
      )
      sample.XX.wb2 <- crossprod(
        EXO.wb2,
        EXO.wb2 * cluster.size
      )


      sample.clz.Y2.res <- vector("list", ncluster.sizes)
      sample.clz.Y2.XX <- vector("list", ncluster.sizes)
      sample.clz.Y2.B <- vector("list", ncluster.sizes)

      if (length(between.y.idx) > 0L) {
        sample.clz.ZZ.res <- vector("list", ncluster.sizes)
        sample.clz.ZZ.XX <- vector("list", ncluster.sizes)
        sample.clz.ZZ.B <- vector("list", ncluster.sizes)

        sample.clz.YZ.res <- vector("list", ncluster.sizes)
        sample.clz.YZ.XX <- vector("list", ncluster.sizes)
        sample.clz.YresXZ <- vector("list", ncluster.sizes)
        sample.clz.XWZres <- vector("list", ncluster.sizes)
      }
      for (clz in seq_len(ncluster.sizes)) {
        # cluster size
        nj <- cluster.sizes[clz]
        nj.idx <- which(cluster.size == nj)

        # Y2
        Y2.clz <- Y2[nj.idx, y1.idx, drop = FALSE]
        if (length(x1.idx) > 0L) {
          EXO2.clz <- cbind(1, Y2[nj.idx, x1.idx, drop = FALSE])
        } else {
          EXO2.clz <- matrix(1, nrow(Y2.clz), 1L)
        }
        XX.clz <- crossprod(EXO2.clz)
        clz.Y2.B <- try(solve(XX.clz, crossprod(EXO2.clz, Y2.clz)),
          silent = TRUE
        )
        if (inherits(clz.Y2.B, "try-error")) {
          clz.Y2.B <-
            MASS::ginv(XX.clz) %*% crossprod(EXO2.clz, Y2.clz)
        }
        clz.Y2.hat <- EXO2.clz %*% clz.Y2.B
        clz.Y2.res <- Y2.clz - clz.Y2.hat
        sample.clz.Y2.B[[clz]] <- clz.Y2.B
        sample.clz.Y2.res[[clz]] <- crossprod(clz.Y2.res)
        sample.clz.Y2.XX[[clz]] <- crossprod(EXO2.clz)

        # Z
        if (length(between.y.idx) > 0L) {
          Z.clz.z <- Y2[nj.idx, between.y.idx, drop = FALSE]
          if (length(between.x.idx) > 0L) {
            EXO.clz.z <- cbind(
              1,
              Y2[nj.idx, between.x.idx, drop = FALSE]
            )
          } else {
            EXO.clz.z <- matrix(1, nrow(Z.clz.z), 1L)
          }
          ZZ.clz <- crossprod(EXO.clz.z)
          clz.ZZ.B <- try(
            solve(
              ZZ.clz,
              crossprod(EXO.clz.z, Z.clz.z)
            ),
            silent = TRUE
          )
          if (inherits(clz.ZZ.B, "try-error")) {
            clz.ZZ.B <-
              MASS::ginv(ZZ.clz) %*% crossprod(EXO.clz.z, Z.clz.z)
          }
          clz.Z.hat <- EXO.clz.z %*% clz.ZZ.B
          clz.Z.res <- Z.clz.z - clz.Z.hat
          sample.clz.ZZ.B[[clz]] <- clz.ZZ.B
          sample.clz.ZZ.res[[clz]] <- crossprod(clz.Z.res)
          sample.clz.ZZ.XX[[clz]] <- crossprod(EXO.clz.z)

          sample.clz.YZ.res[[clz]] <- crossprod(clz.Y2.res, clz.Z.res)
          sample.clz.YZ.XX[[clz]] <- crossprod(EXO2.clz, EXO.clz.z)
          sample.clz.YresXZ[[clz]] <- crossprod(clz.Y2.res, EXO.clz.z)
          sample.clz.XWZres[[clz]] <- crossprod(EXO2.clz, clz.Z.res)
        }
      } # clz
    } # conditional.x

    YLp[[l]] <- list(
      Y1Y1 = Y1Y1,
      Y2 = Y2, s = s, S.b = S.b, S.PW.start = S.PW.start,
      Sigma.W = S.w, Mu.W = Mu.W,
      Sigma.B = Sigma.B, Mu.B = Mu.B,
      Mu.B.start = Mu.B.start, loglik.x = loglik.x,
      mean.d = mean.d, cov.d = cov.d
    )

    # if conditional, add more stuff
    if (conditional.x) {
      if (length(between.y.idx) > 0L) {
        extra <- list(
          sample.wb = sample.wb,
          sample.YYres.wb1 = sample.YYres.wb1,
          sample.XX.wb1 = sample.XX.wb1,
          sample.wb2 = sample.wb2,
          sample.YYres.wb2 = sample.YYres.wb2,
          sample.YresX.wb2 = sample.YresX.wb2,
          sample.XX.wb2 = sample.XX.wb2,
          sample.clz.Y2.res = sample.clz.Y2.res,
          sample.clz.Y2.XX = sample.clz.Y2.XX,
          sample.clz.Y2.B = sample.clz.Y2.B,
          sample.clz.ZZ.res = sample.clz.ZZ.res,
          sample.clz.ZZ.XX = sample.clz.ZZ.XX,
          sample.clz.ZZ.B = sample.clz.ZZ.B,
          sample.clz.YZ.res = sample.clz.YZ.res,
          sample.clz.YZ.XX = sample.clz.YZ.XX,
          sample.clz.YresXZ = sample.clz.YresXZ, # zero?
          sample.clz.XWZres = sample.clz.XWZres
        )
      } else {
        extra <- list(
          sample.wb = sample.wb,
          sample.YYres.wb1 = sample.YYres.wb1,
          sample.XX.wb1 = sample.XX.wb1,
          sample.wb2 = sample.wb2,
          sample.YYres.wb2 = sample.YYres.wb2,
          sample.YresX.wb2 = sample.YresX.wb2,
          sample.XX.wb2 = sample.XX.wb2,
          sample.clz.Y2.res = sample.clz.Y2.res,
          sample.clz.Y2.XX = sample.clz.Y2.XX,
          sample.clz.Y2.B = sample.clz.Y2.B
        )
      }
      YLp[[l]] <- c(YLp[[l]], extra)
    }
  } # l

  YLp
}

lav_points_beziers <- function(x,
  y = NULL,
  col = par("col"),
  lwd = par("lwd")
) {
  if (is.null(y)) {
    if (dim(x)[1L] == 2) {
      p_x <- x[1L, ]
      p_y <- x[2L, ]
    } else {
      p_x <- x[, 1L]
      p_y <- x[, 2L]
    }
  } else {
    p_x <- x
    p_y <- y
  }
  stopifnot(length(p_x) == length(p_y))
  t <- seq(0, 1, length.out = 50)
  if (length(p_x) == 3L) {
    punten_x <- (1 - t)^2 * p_x[1] + 2 * (1 - t) * t * p_x[2] + t^2 * p_x[3]
    punten_y <- (1 - t)^2 * p_y[1] + 2 * (1 - t) * t * p_y[2] + t^2 * p_y[3]
  } else {
    punten_x <- (1 - t)^3 * p_x[1] + 3 * t * (1 - t)^2 * p_x[2] +
      3 * t^2 * (1 - t) * p_x[3] + t^3 * p_x[4]
    punten_y <- (1 - t)^3 * p_y[1] + 3 * t * (1 - t)^2 * p_y[2] +
      3 * t^2 * (1 - t) * p_y[3] + t^3 * p_y[4]
  }
  lines(punten_x, punten_y, col = col, lwd = lwd)
}

lav_plotinfo_rgraph <- function(plotinfo,
                                sloped.labels = TRUE,
                                outfile = "",
                                addgrid = TRUE,
                                mlovcolors = c("lightgreen", "lightblue"),
                                lightness = 1,
                                italic = TRUE,
                                auto.subscript = TRUE) {
  font <- ifelse(italic, 3L, 1L)
  node_elements <- function(nodetiepe, noderadius) {
    # define form, color and anchors for a node type
    thetas <- switch(nodetiepe,
      lv = ,
      varlv = seq(0, 2 * pi, length.out = 50L),
      ov = seq(pi / 4, 2 * pi, by = pi / 2),
      wov = ,
      bov = c(
        seq(pi / 4 - pi / 10, pi / 4 + pi / 10, by = pi / 60),
        seq(3 * pi / 4 - pi / 10, 3 * pi / 4 + pi / 10, by = pi / 60),
        seq(5 * pi / 4 - pi / 10, 5 * pi / 4 + pi / 10, by = pi / 60),
        seq(7 * pi / 4 - pi / 10, 7 * pi / 4 + pi / 10, by = pi / 60)
      ),
      cv = seq(0, 2 * pi, by = pi / 3),
      const = seq(pi / 2, 2 * pi, by = 2 * pi / 3)
    )
    localradius <- noderadius
    if (nodetiepe == "varlv") localradius <- noderadius * .8
    drawx <- localradius * cos(thetas)
    drawy <- localradius * sin(thetas)
    wovbovflat <- max(drawx)
    boxcol <- switch(nodetiepe,
      lv = NA_integer_,
      varlv = NA_integer_,
      ov = NA_integer_,
      wov = mlovcolors[1L],
      bov = mlovcolors[2L],
      cv = NA_integer_,
      const = NA_integer_
    )
    n <- c(0, switch(nodetiepe,
      lv = ,
      varlv = ,
      const = localradius,
      ov = localradius * sqrt(2) / 2,
      wov = ,
      bov = wovbovflat,
      cv = localradius * sqrt(3) / 2
    ))
    s <- c(0, switch(nodetiepe,
      lv = ,
      varlv = -localradius,
      ov = -localradius * sqrt(2) / 2,
      wov = ,
      bov = -wovbovflat,
      cv = -localradius * sqrt(3) / 2,
      const = -localradius * 0.5
    ))
    e <- switch(nodetiepe,
      lv = ,
      varlv = ,
      cv = c(localradius, 0),
      ov = c(localradius * sqrt(2) / 2, 0),
      wov = ,
      bov = c(wovbovflat, 0),
      const = c(localradius * sqrt(3) / 2, -localradius * 0.5)
    )
    w <- c(-e[1L], e[2L])
    ne <- switch(nodetiepe,
      lv = ,
      varlv = ,
      ov = ,
      wov = ,
      bov = localradius * sqrt(0.5) * c(1, 1),
      cv = localradius * c(0.5, sqrt(3) / 2),
      const = e
    )
    nw <- c(-ne[1L], ne[2L])
    se <- switch(nodetiepe,
      lv = ,
      varlv = ,
      ov = ,
      wov = ,
      bov = localradius * sqrt(0.5) * c(1, -1),
      cv = localradius * c(0.5, -sqrt(3) / 2),
      const = e
    )
    sw <- c(-se[1L], se[2L])
    list(
      drawx = drawx, drawy = drawy, boxcol = boxcol, n = n, ne = ne, e = e,
      se = se, s = s, sw = sw, w = w, nw = nw
    )
  }

  vecrotate <- function(vec, angle) {
    c(
      cos(angle) * vec[1] + sin(angle) * vec[2],
      -sin(angle) * vec[1] + cos(angle) * vec[2]
    )
  }
  plot_arrow <- function(tip, dirvec) {
    unitvec <- dirvec / sqrt(sum(dirvec^2))
    arrowangle <- pi * 25 / 180
    arrowinset <- 0.4
    args <- rbind(
      tip,
      tip + vecrotate(-unitvec * arrowlength, arrowangle),
      tip - unitvec * arrowlength * (1 - arrowinset),
      tip + vecrotate(-unitvec * arrowlength, -arrowangle)
    )
    polygon(args, col = "black", border = NA)
  }
  plot_edge <- function(van, naar, label = "", dubbel = FALSE,
                        control = NA_real_, below = FALSE, txtcex = 0.9) {
    labele <- lav_label_code(label, auto.subscript = auto.subscript)$r
    dirvec <- naar - van
    theta <- atan2(naar[2] - van[2], naar[1] - van[1])
    srt <- ifelse(sloped.labels, 180 * theta / pi, 0)
    if (srt > 90) srt <- srt - 180
    if (srt < -90) srt <- srt + 180
    if (is.na(control[1L])) {
      args <- rbind(van, naar)
      lines(args, lwd = 2)
      plot_arrow(naar, dirvec)
      if (dubbel) plot_arrow(van, -dirvec)
      midden <- (van + naar) * 0.5
    } else {
      # gebogen lijn (quadratic lav_points_beziers)
      lav_points_beziers(rbind(van, control, naar), lwd = 2)
      midden <- (van + naar) / 4 + control / 2
      plot_arrow(naar, naar - control)
      if (dubbel) plot_arrow(van, van - control)
    }
    if (label != "") {
      if (below) {
        if (theta >= 0 && theta < 90) {
          text(midden[1L], midden[2L], labele,
            adj = c(0, 1),
            srt = srt, cex = txtcex, font = font
          )
        } else if (theta >= 90) {
          text(midden[1L], midden[2L], labele,
            adj = c(1, 1),
            srt = srt, cex = txtcex, font = font
          )
        } else if (theta < -90) {
          text(midden[1L], midden[2L], labele,
            adj = c(0, 1),
            srt = srt, cex = txtcex, font = font
          )
        } else {
          text(midden[1L], midden[2L], labele,
            adj = c(1, 1),
            srt = srt, cex = txtcex, font = font
          )
        }
      } else {
        if (theta >= 0 && theta < 90) {
          text(midden[1L], midden[2L], labele,
            adj = c(1, 0),
            srt = srt, cex = txtcex, font = font
          )
        } else if (theta >= 90) {
          text(midden[1L], midden[2L], labele,
            adj = c(0, 0),
            srt = srt, cex = txtcex, font = font
          )
        } else if (theta < -90) {
          text(midden[1L], midden[2L], labele,
            adj = c(1, 0),
            srt = srt, cex = txtcex, font = font
          )
        } else {
          text(midden[1L], midden[2L], labele,
            adj = c(0, 0),
            srt = srt, cex = txtcex, font = font
          )
        }
      }
    }
  }
  plot_var <- function(waar, noderadius, label = "", side = "n", txtcex = 0.9) {
    labele <- lav_label_code(label, auto.subscript = auto.subscript)$r
    thetarange <- c(pi / 6, 11 * pi / 6)
    if (side == "s") thetarange <- thetarange + pi / 2
    if (side == "e") thetarange <- thetarange + pi
    if (side == "n") thetarange <- thetarange + 3 * pi / 2
    localradius <- noderadius * 0.8
    middelpt <- switch(side,
      n = c(0, localradius),
      w = c(-localradius, 0),
      s = c(0, -localradius),
      e = c(localradius, 0)
    )
    middelpt <- middelpt + waar
    # cirkelsegment
    thetas <- seq(thetarange[1L], thetarange[2L], length.out = 40)
    straal <- localradius
    xs <- middelpt[1] + cos(thetas) * straal
    ys <- middelpt[2] + sin(thetas) * straal
    lines(xs, ys)
    # pijlen
    plot_arrow(c(xs[1], ys[1]), c(sin(thetarange[1]), -cos(thetarange[1])))
    plot_arrow(c(xs[40], ys[40]), c(-sin(thetarange[2]), cos(thetarange[2])))
    # label
    if (label != "") {
      text(middelpt[1L], middelpt[2L], labele,
        adj = 0.5, cex = txtcex * 0.8,
        font = font
      )
    }
  }
  plot_node <- function(waar, tiepe, label = "", txtcex = 0.9) {
    labele <- lav_label_code(label, auto.subscript = auto.subscript)$r
    elems <- node_elements(tiepe, noderadius)
    x <- waar[1] + elems$drawx
    y <- waar[2] + elems$drawy
    polygon(x, y, col = elems$boxcol, lwd = 1)
    text(waar[1L], waar[2L], labele, adj = 0.5, cex = txtcex, font = font)
  }
  mlrij <- plotinfo$mlrij
  if (is.null(mlrij)) {
    lav_msg_stop(gettext(
      "plotinfo hasn't been processed by lav_plotinfo_positions!"
    ))
  }
  nodes <- plotinfo$nodes
  edges <- plotinfo$edges
  noderadius <- 0.3
  arrowlength <- noderadius / 3
  rijen <- max(nodes$rij)
  kolommen <- max(nodes$kolom)
  if (outfile != "") png(outfile, 960, 960, "px")
  opar <- par(mar = c(1L, 1L, 1L, 1L) + 0.1)
  plot.default(
    x = c(0, lightness * kolommen + 1),
    c(0, lightness * rijen + 1), type = "n",
    xlab = "", ylab = "", axes = FALSE, asp = 1
  )
  if (addgrid) {
    abline(
      v = seq.int(kolommen) * lightness,
      h = seq.int(rijen) * lightness,
      lwd = 1,
      lty = "dotted", col = "lightgray"
    )
    text(seq.int(kolommen) * lightness, 0.3,
      labels = seq.int(kolommen), adj = 1, cex = 0.7
    )
    text(0.3, seq.int(rijen) * lightness,
      labels = seq.int(rijen, 1), adj = 1, cex = 0.7
    )
  }
  if (mlrij > 0L) abline(h = rijen - mlrij + 1, lwd = 2)
  for (j in seq.int(nrow(edges))) {
    if (edges$naar[j] != edges$van[j]) {
      van <- which(nodes$id == edges$van[j])
      naar <- which(nodes$id == edges$naar[j])
      adrvan <- lightness *
        c(nodes$kolom[van], rijen - nodes$rij[van] + 1)
      elems <- node_elements(nodes$tiepe[van], noderadius)
      adrvan <- adrvan + elems[[edges$vananker[j]]]
      adrnaar <- lightness *
        c(nodes$kolom[naar], rijen - nodes$rij[naar] + 1)
      elems <- node_elements(nodes$tiepe[naar], noderadius)
      adrnaar <- adrnaar + elems[[edges$naaranker[j]]]
      if (is.na(edges$controlpt.rij[j])) {
        plot_edge(adrvan, adrnaar, edges$label[j],
          dubbel = (edges$tiepe[j] == "~~"),
          below = edges$labelbelow[j]
        )
      } else {
        controlpt <- lightness * c(
          edges$controlpt.kol[j],
          rijen - edges$controlpt.rij[j] + 1
        )
        plot_edge(adrvan, adrnaar, edges$label[j],
          dubbel = (edges$tiepe[j] == "~~"),
          below = edges$labelbelow[j],
          control = controlpt
        )
      }
    } else {
      van <- which(nodes$id == edges$van[j])
      adrvan <- lightness * c(nodes$kolom[van], rijen - nodes$rij[van] + 1)
      elems <- node_elements(nodes$tiepe[van], noderadius)
      adrvan <- adrvan + elems[[edges$vananker[j]]]
      plot_var(adrvan, noderadius, edges$label[j], edges$vananker[j])
    }
  }
  for (j in seq.int(nrow(nodes))) {
    plot_node(
      lightness *
        c(nodes$kolom[j], rijen - nodes$rij[j] + 1),
      nodes$tiepe[j],
      nodes$naam[j]
    )
  }
  par(opar)
  if (outfile != "") dev.off()
  invisible(NULL)
}

# rotation algorithms for multiple groups
#
# YR 22 Dec 2025 -- initial version
#
# - rstarts only affects the 'initial' rotation

# main function to rotate a list of matrices 'Alist'
lav_matrix_rotate_mg <- function(Alist = NULL, # original matrices
                                 orthogonal = FALSE, # default is oblique
                                 method = "geomin", # default rot method
                                 method.args = list(
                                   geomin.epsilon = 0.01,
                                   orthomax.gamma = 1,
                                   cf.gamma = 0,
                                   oblimin.gamma = 0,
                                   promax.kappa = 4,
                                   target = matrix(0, 0, 0),
                                   target.mask = matrix(0, 0, 0)
                                 ),
                                 init.rotList = NULL, # initial rotation matrix
                                 init.ROT.check = TRUE, # check if init ROT is ok
                                 rstarts = 30L, # number of random starts
                                 # row.weights = "default", # row weighting
                                 # std.ov = FALSE, # rescale ov
                                 # ov.var = NULL, # ov variances
                                 # algorithm = "gpa", # rotation algorithm
                                 mg.algorithm = "pairwise",
                                 mg.agreement.method = "procrustes",
                                 mg.agreement.weight = 0.5,
                                 reflect = TRUE, # refect sign
                                 order.lv.by = "index", # how to order the lv's
                                 # gpa.tol = 0.00001, # stopping tol gpa
                                 tol = 1e-07, # stopping tol others
                                 keep.rep = FALSE, # store replications
                                 max.iter = 10000L) { # max iterations

  # check Alist
  if (!is.list(Alist)) {
    lav_msg_stop(gettext("Alist does not seem to be a list"))
  }
  ngroups <- length(Alist)

  # check A
  A <- Alist[[1]]
  if (!inherits(A, "matrix")) {
    lav_msg_stop(gettext("A does not seem to be a matrix"))
  }

  P <- nrow(A)
  M <- ncol(A)
  if (M < 2L) { # single dimension
    res <- list(
      lambdaList = Alist, rotList = NULL,
      orthogonal = orthogonal, method = "none",
      method.args = list(), row.weights = "none",
      algorithm = "none", iter = 0L, converged = TRUE,
      method.value = 0
    )
    return(res)
  }

  # method
  method <- tolower(method)

  # no promax (for now)
  if (method == "promax") {
    lav_msg_stop(gettext("mg-promax + agreement not supported"))
  }

  # check init.ROT per group
  if (!is.null(init.rotList) && init.ROT.check) {
    for(g in seq_len(ngroups)) {
      init.ROT <- init.rotList[[g]]
      if (!inherits(init.ROT, "matrix")) {
        lav_msg_stop(gettext("init.ROT does not seem to a matrix"))
      }
      if (nrow(init.ROT) != M) {
        lav_msg_stop(gettextf(
          "nrow(init.ROT) = %1$s does not equal ncol(A) = %2$s",
          nrow(init.ROT), M
        ))
      }
      if (nrow(init.ROT) != ncol(init.ROT)) {
        lav_msg_stop(gettextf(
          "nrow(init.ROT) = %1$s does not equal ncol(init.ROT) = %2$s",
          nrow(init.ROT), ncol(init.ROT)
        ))
      }
      # rotation matrix?
      if (!lav_matrix_rotate_check(init.ROT, orthogonal = orthogonal)) {
        lav_msg_stop(gettext("init.ROT does not look like a rotation matrix"))
      }
    } # group
  } # check init.rotList

  # determine method function name
  if (method %in% c(
    "cf-quartimax", "cf-varimax", "cf-equamax",
    "cf-parsimax", "cf-facparsim"
  )) {
    method.fname <- "lav_matrix_rotate_cf"
    method.args$cf.gamma <- switch(method,
      "cf-quartimax" = 0,
      "cf-varimax"   = 1 / P,
      "cf-equamax"   = M / (2 * P),
      "cf-parsimax"  = (M - 1) / (P + M - 2),
      "cf-facparsim" = 1
    )
  } else if (method %in% c("bi-quartimin", "biquartimin")) {
    method.fname <- "lav_matrix_rotate_biquartimin"
  } else if (method %in% c("bi-geomin", "bigeomin")) {
    method.fname <- "lav_matrix_rotate_bigeomin"
  } else if (method == "target.strict") {
    method.fname <- "lav_matrix_rotate_target"
  } else {
    method.fname <- paste("lav_matrix_rotate_", method, sep = "")
  }

  # check if rotation method exists
  check <- try(get(method.fname), silent = TRUE)
  if (inherits(check, "try-error")) {
    lav_msg_stop(gettext("unknown rotation method:"), method.fname)
  }

  # if target, check target matrix
  if (method == "target.strict" || method == "pst") {
    target <- method.args$target
    if (is.list(target)) {
      method.args$target <- target <- target[[1L]] # always take the first group
    }
    # check dimension of target/A
    if (nrow(target) != nrow(A)) {
      lav_msg_stop(gettext("nrow(target) != nrow(A)"))
    }
    if (ncol(target) != ncol(A)) {
      lav_msg_stop(gettext("ncol(target) != ncol(A)"))
    }
  }
  if (method == "pst") {
    target.mask <- method.args$target.mask
    if (is.list(target.mask)) {
      method.args$target.mask <- target.mask <- target.mask[[1L]]
    }
    # check dimension of target.mask/A
    if (nrow(target.mask) != nrow(A)) {
      lav_msg_stop(gettext("nrow(target.mask) != nrow(A)"))
    }
    if (ncol(target.mask) != ncol(A)) {
      lav_msg_stop(gettext("col(target.mask) != ncol(A)"))
    }
  }
  # we keep this here, so lav_matrix_rotate() can be used independently
  if (method == "target.strict" && anyNA(target)) {
    method <- "pst"
    method.fname <- "lav_matrix_rotate_pst"
    target.mask <- matrix(1, nrow = nrow(target), ncol = ncol(target))
    target.mask[is.na(target)] <- 0
    method.args$target.mask <- target.mask
  }

  # set orthogonal option
  if (missing(orthogonal)) {
    # the default is oblique, except for varimax, entropy and a few others
    if (method %in% c(
      "varimax", "entropy", "mccammon",
      "tandem1", "tandem2"
    )) {
      orthogonal <- TRUE
    } else {
      orthogonal <- FALSE
    }
  } else {
    if (!orthogonal && method %in% c(
      "varimax", "entropy", "mccammon",
      "tandem1", "tandem2"
    )) {
      lav_msg_warn(gettextf(
        "rotation method %s may not work with oblique rotation.",
        dQuote(method)
      ))
    }
  }

  # 0. initialize: rotate each group separately + reorder
  Alist.orig <- Alist
  orderList <- vector("list", length = ngroups)
  for (g in seq_len(ngroups)) {
    if (lav_verbose()) {
      cat("  group = ", g, "\n")
    }
    res0 <- lav_matrix_rotate(
      A = Alist[[g]],
      orthogonal = orthogonal,
      method = method,
      method.args = method.args,
      init.ROT = NULL,
      init.ROT.check = FALSE,
      rstarts = rstarts,
      row.weights = "none",
      std.ov = FALSE,
      ov.var = NULL,
      algorithm = "pairwise",
      reflect = reflect,
      order.lv.by = order.lv.by,
      tol = tol,
      max.iter = max.iter,
      group = g
    )
    if (g > 1L) {
      # reorder factors to align with the first group
      order.idx <- lav_efa_find_best_order(
        lambda_ref = Alist[[1]],
        lambda_target = res0$LAMBDA
      )
      Alist[[g]] <- res0$LAMBDA[, order.idx, drop = FALSE]
      orderList[[g]] <- order.idx
    } else {
      Alist[[g]] <- res0$LAMBDA
      orderList[[g]] <- res0$order.idx
    }
  } # group

  #  # set row.weights
  #  row.weights <- tolower(row.weights)
  #  if (row.weights == "default") {
  #    # the default is "none", except for varimax
  #    if (method %in% c("varimax", "promax")) {
  #      row.weights <- "kaiser"
  #    } else {
  #      row.weights <- "none"
  #    }
  #  }

  #   # check algorithm
  #   algorithm <- tolower(algorithm)
  #   if (algorithm %in% c("gpa", "pairwise", "none")) {
  #     # nothing to do
  #   } else {
  #     lav_msg_stop(gettext("algorithm must be gpa or pairwise"))
  #   }

  # 1. compute row weigths

  #   # 1.a cov -> cor?
  #   if (std.ov) {
  #     A <- A * 1 / sqrt(ov.var)
  #   }
  #
  #   if (row.weights == "none") {
  #     weights <- rep(1.0, P)
  #   } else if (row.weights == "kaiser") {
  #     weights <- lav_matrix_rotate_kaiser_weights(A)
  #   } else if (row.weights == "cureton-mulaik") {
  #     weights <- lav_matrix_rotate_cm_weights(A)
  #   } else {
  #     lav_msg_stop(gettext("row.weights can be none, kaiser or cureton-mulaik"))
  #   }
  #   A <- A * weights


  # 2. rotate

  # multiple random starts?
#  if (rstarts > 0L) {
#    REP <- lapply(seq_len(rstarts), function(rep) {
#      # random start (always orthogonal)
#      # init.ROT <- lav_matrix_rotate_gen(M = M, orthogonal = TRUE)
#      # init.ROT <- lav_matrix_rotate_gen(M = M, orthogonal = orthogonal)
#
#      if (lav_verbose()) {
#        cat("\n")
#        cat("rstart = ", sprintf("%4d", rep), " start:\n")
#      }
#
#      # mg-pairwise + agreement
#      rotList <- lav_matrix_rotate_pairwise_mg(
#        Alist = Alist,
#        orthogonal = orthogonal,
#        random.ROT = TRUE,
#        method.fname = method.fname,
#        method.args = method.args,
#        tol = tol,
#        max.iter = max.iter
#      )
#      info <- attr(rotList, "info")
#      attr(rotList, "info") <- NULL
#      res <- list(value = info$method.value, rotList = rotList)
#
#      if (lav_verbose()) {
#        cat(
#          "rstart = ", sprintf("%4d", rep),
#          " end; current crit = ", sprintf("%17.15f", res$value), "\n"
#        )
#      }
#      res
#    })
#    best.idx <- which.min(sapply(REP, "[[", "value"))
#    rotList <- REP[[best.idx]]$rotList
#    if (keep.rep) {
#      info <- list(method.value = REP[[best.idx]]$value, REP = REP)
#    } else {
#      info <- list(method.value = REP[[best.idx]]$value)
#    }
#  } else { # just a single rstart
    # initial rotation matrix
    # if (is.null(init.ROT)) {
    #   init.ROT <- diag(M)
    # }

    if (lav_verbose()) {
      cat("  mg-pairwise + agreement rotation:\n")
    }
    rotList <- lav_matrix_rotate_pairwise_mg(
      Alist = Alist,
      orthogonal = orthogonal,
      random.ROT = FALSE,
      method.fname = method.fname,
      method.args = method.args,
      mg.agreement.method = mg.agreement.method,
      mg.agreement.weight = mg.agreement.weight,
      tol = tol,
      max.iter = max.iter
    )
    info <- attr(rotList, "info")
    attr(rotList, "info") <- NULL
  #}
  lambdaList <- vector("list", length = ngroups)
  for (g in seq_len(ngroups)) {
    A <- Alist[[g]]
    ROT <- rotList[[g]]

    if (orthogonal) {
      # LAMBDA <- A %*% solve(t(ROT))
      # note: when ROT is orthogonal, solve(t(ROT)) == ROT
      LAMBDA <- A %*% ROT
    } else {
      # LAMBDA <- A %*% solve(t(ROT))
      LAMBDA <- t(solve(ROT, t(A)))
    }

    #  # 3. undo row weighting
    #  LAMBDA <- LAMBDA / weights

    #  # 3.b undo cov -> cor
    #  if (std.ov) {
    #    LAMBDA <- LAMBDA * sqrt(ov.var)
    #  }

    # put back in List
    lambdaList[[g]] <- LAMBDA
  } # group

  # re-compute final rotation matrix, using Alist.orig
  # because in step 0, we already rotated (per group)
  rotList <- vector("list", length = ngroups)
  if (orthogonal) {
    for (g in seq_len(ngroups)) {
      rotList[[g]] <- solve(
        crossprod(Alist.orig[[g]]),
        crossprod(Alist.orig[[g]], lambdaList[[g]])
      )
    }
  } else {
    for (g in seq_len(ngroups)) {
      # to be compatible with GPa
      ROTt.inv <- solve(
        crossprod(Alist.orig[[g]]),
        crossprod(Alist.orig[[g]], lambdaList[[g]])
      )
      rotList[[g]] <- solve(t(ROTt.inv))
    }
  }

  # 6. return results as a list
  res <- list(
    lambdaList = lambdaList, rotList = rotList,
    orderList = orderList,
    orthogonal = orthogonal, method = method,
    method.args = method.args, row.weights = "none"
  )

  # add method info
  res <- c(res, info)

  res
}


# pairwise rotation algorithm with direct line search
# (see lav_matrix_rotate_pairwise()
#
# but adapted to handle multiple groups + an agreement criterion
#
lav_matrix_rotate_pairwise_mg <- function(Alist = NULL, # original matrices
                                          orthogonal = FALSE,
                                          random.ROT = FALSE,
                                          method.fname = NULL, # crit function
                                          method.args = list(), # method args
                                          tol = 1e-8,
                                          mg.agreement.weight = 0.50,
                                          mg.agreement.method = "procrustes",
                                          scale = TRUE,
                                          max.iter = 1000L) {
  # first group is 'A'
  A <- Alist[[1]]
  ngroups <- length(Alist)

  # number of columns
  M <- ncol(A)

  # initial LAMBDA + PSI
  lambdaList <- Alist
  psiList <- rep(list(diag(M)), ngroups)

  # random initial rotation?
  if (random.ROT) {
    for (g in seq_len(ngroups)) {
      init.ROT <- lav_matrix_rotate_gen(M = M, orthogonal = TRUE)
      if (orthogonal) {
        lambdaList[[g]] <- Alist[[g]] %*% init.ROT
      } else {
        lambdaList[[g]] <- t(solve(init.ROT, t(Alist[[g]])))
        psiList[[g]] <- crossprod(init.ROT)
      }
    }
  }

  # using the current LAMBDA, evaluate the user-specified
  # rotation criteron; return Q (the criterion) only
  Q.current <- lav_matrix_rotate_mg_agreement(
    lambdaList = lambdaList, method.fname = method.fname,
    method.args = method.args,
    mg.agreement.method = mg.agreement.method,
    w = mg.agreement.weight, scale = scale
  )

  # if verbose, print
  if (lav_verbose()) {
    Q.mg <- attr(Q.current, "Q.mg")
    A.mg <- attr(Q.current, "A.mg")
    cat(
      "  iter = ", sprintf("%4d", 0),
      " Q = ", sprintf("%13.11f", Q.current),
      " Q.rot = ", sprintf("%13.11f", Q.mg),
      " Q.agr = ", sprintf("%13.11f", A.mg), "\n"
    )
  }

  # plane combinations
  if (orthogonal) {
    PLANE <- utils::combn(M, 2)
  } else {
    tmp <- utils::combn(M, 2)
    PLANE <- cbind(tmp, tmp[c(2, 1), , drop = FALSE])
  }

  # define objective function -- orthogonal
  objf_orth <- function(g = 1L, theta = 0, A = NULL, col1 = 0L, col2 = 0L) {
    # construct ROT
    ROT <- diag(M)
    ROT[col1, col1] <- base::cos(theta)
    ROT[col1, col2] <- base::sin(theta)
    ROT[col2, col1] <- -1 * base::sin(theta)
    ROT[col2, col2] <- base::cos(theta)

    # rotate
    lambdaList[[g]] <- A %*% ROT

    # evaluate criterion
    Q <- lav_matrix_rotate_mg_agreement(
      lambdaList = lambdaList, method.fname = method.fname,
      method.args = method.args, mg.agreement.method = mg.agreement.method,
      w = mg.agreement.weight, scale = scale
    )

    Q
  }

  # define objective function -- oblique
  objf_obliq <- function(g = 1, delta = 0, A = NULL, col1 = 0L, col2 = 0L,
                         psi12 = 0) {
    # construct ROT
    ROT <- diag(M)

    # gamma
    gamma2 <- 1 + (2 * delta * psi12) + (delta * delta)

    ROT[col1, col1] <- sqrt(abs(gamma2))
    ROT[col1, col2] <- -1 * delta
    ROT[col2, col1] <- 0
    ROT[col2, col2] <- 1

    # rotate
    lambdaList[[g]] <- A %*% ROT

    # evaluate criterion
    Q <- lav_matrix_rotate_mg_agreement(
      lambdaList = lambdaList, method.fname = method.fname,
      method.args = method.args, mg.agreement.method = mg.agreement.method,
      w = mg.agreement.weight, scale = scale
    )

    Q
  }

  # start iterations
  converged <- FALSE
  Q.old <- Q.current
  for (iter in seq_len(max.iter)) {
    # for each group
    for (g in seq_len(ngroups)) {
      # rotate - one cycle
      for (pl in seq_len(ncol(PLANE))) {
        # choose plane
        col1 <- PLANE[1, pl]
        col2 <- PLANE[2, pl]

        # optimize
        if (orthogonal) {
          out <- optimize(
            f = objf_orth, interval = c(-pi / 4, +pi / 4),
            g = g,
            A = lambdaList[[g]], col1 = col1, col2 = col2,
            maximum = FALSE, tol = .Machine$double.eps^0.25
          )
          # best rotation - for this plane
          theta <- out$minimum

          # construct ROT
          ROT <- diag(M)
          ROT[col1, col1] <- base::cos(theta)
          ROT[col1, col2] <- base::sin(theta)
          ROT[col2, col1] <- -1 * base::sin(theta)
          ROT[col2, col2] <- base::cos(theta)
        } else {
          psi12 <- psiList[[g]][col1, col2]
          out <- optimize(
            f = objf_obliq, interval = c(-1, +1),
            g = g,
            A = lambdaList[[g]], col1 = col1, col2 = col2,
            psi12 = psi12,
            maximum = FALSE, tol = .Machine$double.eps^0.25
          )

          # best rotation - for this plane
          delta <- out$minimum

          # construct ROT
          ROT <- diag(M)

          # gamma
          gamma2 <- 1 + (2 * delta * psi12) + (delta * delta)
          gamma <- sqrt(abs(gamma2))

          ROT[col1, col1] <- gamma
          ROT[col1, col2] <- -1 * delta
          ROT[col2, col1] <- 0
          ROT[col2, col2] <- 1
        }

        # rotate
        lambdaList[[g]] <- lambdaList[[g]] %*% ROT

        if (!orthogonal) {
          PSI <- psiList[[g]]
          # rotate PSI
          PSI[col1, ] <- (1 / gamma) * PSI[col1, ] + (delta / gamma) * PSI[col2, ]
          PSI[, col1] <- PSI[col1, ]
          PSI[col1, col1] <- 1
          psiList[[g]] <- PSI
        }
      } # all planes
    } # ngroups

    # check for convergence
    Q.current <- lav_matrix_rotate_mg_agreement(
      lambdaList = lambdaList, method.fname = method.fname,
      method.args = method.args, mg.agreement.method = mg.agreement.method,
      w = mg.agreement.weight, scale = scale
    )

    # absolute change in Q
    diff <- abs(Q.old - Q.current)

    # if verbose, print
    if (lav_verbose()) {
      Q.mg <- attr(Q.current, "Q.mg")
      A.mg <- attr(Q.current, "A.mg")
      cat(
        "  iter = ", sprintf("%4d", iter),
        " Q = ", sprintf("%13.11f", Q.current),
        " Q.rot = ", sprintf("%13.11f", Q.mg),
        " Q.agr = ", sprintf("%13.11f", A.mg),
        " change = ", sprintf("%13.11f", diff), "\n"
      )
    }

    if (!is.finite(diff)) {
      # something went wrong ... bail out
      lav_msg_warn(gettextf("mg-pairwise rotation algorithm failed!"))
      break
    } else if (diff < tol) {
      converged <- TRUE
      break
    } else {
      Q.old <- Q.current
    }
  } # iter

  # warn if no convergence
  if (!converged) {
    lav_msg_warn(gettextf(
      "mg-pairwise rotation algorithm did not converge after %s iterations",
      max.iter
    ))
  }

  # compute final rotation matrix
  rotList <- vector("list", length = ngroups)
  if (orthogonal) {
    for (g in seq_len(ngroups)) {
      rotList[[g]] <- solve(
        crossprod(Alist[[g]]),
        crossprod(Alist[[g]], lambdaList[[g]])
      )
    }
  } else {
    for (g in seq_len(ngroups)) {
      # to be compatible with GPa
      ROTt.inv <- solve(
        crossprod(Alist[[g]]),
        crossprod(Alist[[g]], lambdaList[[g]])
      )
      rotList[[g]] <- solve(t(ROTt.inv))
    }
  }

  # algorithm information
  info <- list(
    algorithm = "mg-pairwise",
    iter = iter,
    converged = converged,
    method.value = Q.current
  )

  attr(rotList, "info") <- info

  rotList
}

# compute model implied statistics
# per block

# YR 7 May 2022: add cov.x and mean.x if conditional.x (so that we do
#                no longer depend on SampleStats)

lav_model_implied <- function(lavmodel = NULL, GLIST = NULL, delta = TRUE) {
  stopifnot(inherits(lavmodel, "lavModel"))

  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  # model-implied variance/covariance matrix ('sigma hat')
  Sigma.hat <- lav_model_sigma(
    lavmodel = lavmodel, GLIST = GLIST,
    delta = delta
  )

  # model-implied mean structure ('mu hat')
  if (lavmodel@meanstructure) {
    Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST = GLIST)
  } else {
    Mu.hat <- vector("list", length = lavmodel@nblocks)
  }

  # if conditional.x, slopes, cov.x, mean.x
  if (lavmodel@conditional.x) {
    SLOPES <- lav_model_pi(lavmodel = lavmodel, GLIST = GLIST)

    # per block, because for some blocks, cov.x may not exist
    COV.X <- vector("list", lavmodel@nblocks)
    MEAN.X <- vector("list", lavmodel@nblocks)
    for (b in seq_len(lavmodel@nblocks)) {
      mm.in.block <- (seq_len(lavmodel@nmat[b]) +
        cumsum(c(0, lavmodel@nmat))[b])
      MLIST <- lavmodel@GLIST[mm.in.block]
      cov.x.idx <- which(names(MLIST) == "cov.x")
      if (length(cov.x.idx) > 0L) {
        COV.X[[b]] <- MLIST[[cov.x.idx]]
      } else {
        COV.X[[b]] <- matrix(0, 0L, 0L)
      }
      mean.x.idx <- which(names(MLIST) == "mean.x")
      if (length(mean.x.idx) > 0L) {
        MEAN.X[[b]] <- MLIST[[mean.x.idx]]
      } else {
        MEAN.X[[b]] <- matrix(0, 0L, 1L)
      }
    }
  } else {
    SLOPES <- vector("list", length = lavmodel@nblocks)
  }

  # if categorical, model-implied thresholds
  if (lavmodel@categorical) {
    TH <- lav_model_th(lavmodel = lavmodel, GLIST = GLIST)
  } else {
    TH <- vector("list", length = lavmodel@nblocks)
  }

  if (lavmodel@group.w.free) {
    w.idx <- which(names(lavmodel@GLIST) == "gw")
    GW <- unname(GLIST[w.idx])
    GW <- lapply(GW, as.numeric)
  } else {
    GW <- vector("list", length = lavmodel@nblocks)
  }

  if (lavmodel@conditional.x) {
    implied <- list(
      res.cov = Sigma.hat, res.int = Mu.hat,
      res.slopes = SLOPES, cov.x = COV.X, mean.x = MEAN.X,
      res.th = TH, group.w = GW
    )
  } else {
    implied <- list(cov = Sigma.hat, mean = Mu.hat, th = TH, group.w = GW)
  }

  implied
}

# convert 'conditional.x = TRUE' to 'conditional.x = FALSE'
lav_model_implied_cond2uncond <- function(lavimplied) {
  # check for res.cov
  if (is.null(lavimplied$res.cov[[1]])) {
    # already unconditional
    return(lavimplied)
  } else {
    nblocks <- length(lavimplied$res.cov)
  }

  COV <- vector("list", length = nblocks)
  MEAN <- vector("list", length = nblocks)

  # reconstruct COV/MEAN per block
  for (b in seq_len(nblocks)) {
    res.Sigma <- lavimplied$res.cov[[b]]
    res.slopes <- lavimplied$res.slopes[[b]]
    res.int <- lavimplied$res.int[[b]]
    S.xx <- lavimplied$cov.x[[b]]
    M.x <- lavimplied$mean.x[[b]]

    S.yx <- res.slopes %*% S.xx
    S.xy <- t(S.yx)
    S.yy <- res.Sigma + tcrossprod(S.yx, res.slopes)
    COV[[b]] <- rbind(cbind(S.yy, S.yx), cbind(S.xy, S.xx))

    Mu.y <- as.vector(res.int + res.slopes %*% M.x)
    Mu.x <- as.vector(M.x)
    MEAN[[b]] <- matrix(c(Mu.y, Mu.x), ncol = 1L)
  }

  # we ignore res.th for now, as we do not support categorical data
  # in the two-level setting anyway
  implied <- list(
    cov = COV, mean = MEAN, th = lavimplied$res.th,
    group.w = lavimplied$group.w
  )

  implied
}

# various rotation criteria and their gradients
# YR 05 April 2019: initial version
# YR 14 June  2019: add more rotation criteria
# YR 22 Dec   2025: add multigroup rotation criteria

# references:
#
# Bernaards, C. A., & Jennrich, R. I. (2005). Gradient projection algorithms
# and software for arbitrary rotation criteria in factor analysis. Educational
# and Psychological Measurement, 65(5), 676-696.
# old website: http://web.archive.org/web/20180708170331/http://www.stat.ucla.edu/research/gpa/splusfunctions.net
#
# Browne, M. W. (2001). An overview of analytic rotation in exploratory factor
# analysis. Multivariate behavioral research, 36(1), 111-150.
#
# Mulaik, S. A. (2010). Foundations of factor analysis (Second Edition).
# Boca Raton: Chapman and Hall/CRC.
#
# De Roover, K., & Vermunt, J. K. (2019). On the exploratory road to unraveling
# factor loading non-invariance: A new multigroup rotation approach. Structural
# Equation Modeling: A Multidisciplinary Journal, 26(6), 905-923.

# Note: this is YR's implementation, not a copy of the GPArotation
#       package
#
# Why did I write my own functions (and not use the GPArotation):
# - to better understand what is going on
# - to have direct access to the gradient functions
# - to avoid yet another dependency
# - to simplify further experiments


# Orthomax family (Harman, 1960)
#
# gamma = 0   -> quartimax
# gamma = 1/2 -> biquartimax
# gamma = 1/P -> equamax
# gamma = 1   -> varimax
#
lav_matrix_rotate_orthomax <- function(LAMBDA = NULL, orthomax.gamma = 1,
                                       ..., grad = FALSE) {
  L2 <- LAMBDA * LAMBDA
  # center L2 column-wise
  cL2 <- t(t(L2) - orthomax.gamma * colMeans(L2))
  out <- -1 * sum(L2 * cL2) / 4

  if (grad) {
    attr(out, "grad") <- -1 * LAMBDA * cL2
  }

  out
}

# Crawford-Ferguson (1970) family
#
# combine penalization for 1) row complexity, and 2) column complexity
# if combined with orthogonal rotation, this is equivalent to the
# orthomax family:
#
#     quartimax -> gamma = 0 (only row complexity)
#     varimax   -> gamma = 1/nrow
#     equamax   -> gamma = ncol/(2*nrow)
#     parsimax  -> gamma = (ncol - 1)/(nrow + ncol - 2)
#     factor parsimony -> gamma = 1 (only column complexity)
#
# the Crawford-Ferguson family is also equivalent to the oblimin family
# if the latter is restricted to orthogonal rotation
#
lav_matrix_rotate_cf <- function(LAMBDA = NULL, cf.gamma = 0, ...,
                                 grad = FALSE) {
  # check if gamma is between 0 and 1?
  nRow <- nrow(LAMBDA)
  nCol <- ncol(LAMBDA)
  ROW1 <- matrix(1.0, nCol, nCol)
  diag(ROW1) <- 0.0
  COL1 <- matrix(1.0, nRow, nRow)
  diag(COL1) <- 0.0

  L2 <- LAMBDA * LAMBDA
  LR <- L2 %*% ROW1
  LC <- COL1 %*% L2

  f1 <- sum(L2 * LR) / 4
  f2 <- sum(L2 * LC) / 4

  out <- (1 - cf.gamma) * f1 + cf.gamma * f2

  if (grad) {
    attr(out, "grad") <- ((1 - cf.gamma) * LAMBDA * LR) +
      (cf.gamma * LAMBDA * LC)
  }

  out
}

# Oblimin family (Carroll, 1960; Harman, 1976)
#
# quartimin   -> gamma = 0
# biquartimin -> gamma = 1/2
# covarimin   -> gamma = 1
#
# if combined with orthogonal rotation, this is equivalent to the
# orthomax family (they have the same optimizers):
#
# gamma = 0   -> quartimax
# gamma = 1/2 -> biquartimax
# gamma = 1   -> varimax
# gamma = P/2 -> equamax
#
lav_matrix_rotate_oblimin <- function(LAMBDA = NULL, oblimin.gamma = 0, ...,
                                      grad = FALSE) {
  nRow <- nrow(LAMBDA)
  nCol <- ncol(LAMBDA)
  ROW1 <- matrix(1.0, nCol, nCol)
  diag(ROW1) <- 0.0

  L2 <- LAMBDA * LAMBDA
  LR <- L2 %*% ROW1
  Jp <- matrix(1, nRow, nRow) / nRow

  # see Jennrich (2002, p. 11)
  tmp <- (diag(nRow) - oblimin.gamma * Jp) %*% LR

  # same as t( t(L2) - gamma * colMeans(L2) ) %*% ROW1

  out <- sum(L2 * tmp) / 4

  if (grad) {
    attr(out, "grad") <- LAMBDA * tmp
  }

  out
}


# quartimax criterion
# Carroll (1953); Saunders (1953) Neuhaus & Wrigley (1954); Ferguson (1954)
# we use here the equivalent 'Ferguson, 1954' variant
# (See Mulaik 2010, p. 303)
lav_matrix_rotate_quartimax <- function(LAMBDA = NULL, ..., grad = FALSE) {
  L2 <- LAMBDA * LAMBDA
  out <- -1 * sum(L2 * L2) / 4

  if (grad) {
    attr(out, "grad") <- -1 * LAMBDA * L2
  }

  out
}


# varimax criterion
# Kaiser (1958, 1959)
#
# special case of the Orthomax family (Harman, 1960), where gamma = 1
# see Jennrich (2001, p. 296)
lav_matrix_rotate_varimax <- function(LAMBDA = NULL, ..., grad = FALSE) {
  L2 <- LAMBDA * LAMBDA
  # center L2 column-wise
  cL2 <- t(t(L2) - colMeans(L2))
  out <- -1 * abs(sum(L2 * cL2)) / 4 # abs needed?

  if (grad) {
    attr(out, "grad") <- -1 * LAMBDA * cL2
  }

  out
}

# quartimin criterion (part of Carroll's oblimin family
lav_matrix_rotate_quartimin <- function(LAMBDA = NULL, ..., grad = FALSE) {
  nCol <- ncol(LAMBDA)
  ROW1 <- matrix(1.0, nCol, nCol)
  diag(ROW1) <- 0.0

  L2 <- LAMBDA * LAMBDA
  LR <- L2 %*% ROW1

  out <- sum(L2 * LR) / 4

  if (grad) {
    attr(out, "grad") <- LAMBDA * LR
  }

  out
}

# Browne's (2001) version of Yates (1984) geomin criterion
#
# we use the exp/log trick as in Bernaard & Jennrich (2005, p. 687)
lav_matrix_rotate_geomin <- function(LAMBDA = NULL, geomin.epsilon = 0.01,
                                     ..., grad = FALSE) {
  nCol <- ncol(LAMBDA)

  L2 <- LAMBDA * LAMBDA
  L2 <- L2 + geomin.epsilon

  if (geomin.epsilon < sqrt(.Machine$double.eps)) {
    # Yates's original formula
    tmp <- apply(L2, 1, prod)^(1 / nCol)
  } else {
    tmp <- exp(rowSums(log(L2)) / nCol)
  }

  out <- sum(tmp)

  if (grad) {
    attr(out, "grad") <- (2 / nCol) * LAMBDA / L2 * tmp
  }

  out
}

# simple entropy
# seems to only work for orthogonal rotation
lav_matrix_rotate_entropy <- function(LAMBDA = NULL, ..., grad = FALSE) {
  L2 <- LAMBDA * LAMBDA

  # handle zero elements -> replace by '1', so log(1) == 0
  L2[L2 == 0] <- 1

  out <- -1 * sum(L2 * log(L2)) / 2

  if (grad) {
    attr(out, "grad") <- -LAMBDA * log(L2) - LAMBDA
  }

  out
}

# McCammon's (1966) Minimum Entropy Criterion
#
# for p-vector x, where x > 0 and sum(x) = 1, we have
# - entropy(x) == 0, if there is only one 1, and all zeroes
# - entropy(x) == max == log(p) if all elements are 1/p
# - entropy(x) is similar as complexity(x), but also measure of equality
#   of elements of x
#
# works only ok with orthogonal rotation!

lav_matrix_rotate_mccammon <- function(LAMBDA = NULL, ..., grad = FALSE) {
  nCol <- ncol(LAMBDA)
  nRow <- nrow(LAMBDA)
  L2 <- LAMBDA * LAMBDA

  # entropy function (Browne, 2001, eq 9)
  f_entropy <- function(x) {
    -1 * sum(ifelse(x > 0, x * log(x), 0))
  }

  # sums of rows/columns/all
  sumi. <- rowSums(L2)
  sum.j <- colSums(L2)
  sum.. <- sum(L2)


  Q1 <- f_entropy(t(L2) / sum.j) # encouraging columns with few large,
  # and many small elements
  Q2 <- f_entropy(sum.j / sum..) # encouraging equal column sums

  # minimize
  out <- log(Q1) - log(Q2)

  if (grad) { # See Bernaards and Jennrich 2005 page 685+686
    H <- -(log(t(t(L2) / sum.j)) + 1)
    G1 <- t(t(H) / sum.j - rowSums(t(L2 * H) / (sum.j * sum.j)))

    h <- -(log(sum.j / sum..) + 1)
    alpha <- as.numeric(h %*% sum.j) / (sum.. * sum..) # paper divides by
    # sum.., not sum..^2??
    G2 <- matrix(h / sum.. - alpha, nRow, nCol, byrow = TRUE)

    attr(out, "grad") <- 2 * LAMBDA * (G1 / Q1 - G2 / Q2)
  }

  out
}


# Infomax
# McKeon (1968, unpublished) and Browne (2001)
# Treat LAMBDA^2 as a contingency table, and use simplicity function based
# on tests for association; most effective was LRT for association
# (see Agresti, 1990, eq 3.13) which is maximized for max simplicity
#
# McKeon: criterion may be regarded as a measure of information about row
# categories conveyed by column categories (and vice versa); hence infomax

# - favors perfect cluster
# - discourages general factor
# - both for orthogonal and oblique rotation

#
# Note: typo in Browne (2001), see last  paragraph of Bernaards and
# Jennrich (2005) page 684
lav_matrix_rotate_infomax <- function(LAMBDA = NULL, ..., grad = FALSE) {
  nCol <- ncol(LAMBDA)
  nRow <- nrow(LAMBDA)
  L2 <- LAMBDA * LAMBDA

  # entropy function (Browne, 2001, eq 9)
  f_entropy <- function(x) {
    -1 * sum(ifelse(x > 0, x * log(x), 0))
  }

  # sums of rows/columns/all
  sumi. <- rowSums(L2)
  sum.j <- colSums(L2)
  sum.. <- sum(L2)

  Q1 <- f_entropy(L2 / sum..) # Bernaards & Jennrich version!! (Browne
  # divides by sum.j, like in McCammon)
  Q2 <- f_entropy(sum.j / sum..)
  Q3 <- f_entropy(sumi. / sum..)

  # minimize
  out <- log(nCol) + Q1 - Q2 - Q3

  if (grad) {
    H <- -(log(L2 / sum..) + 1)
    alpha <- sum(L2 * H) / (sum.. * sum..)
    G1 <- H / sum.. - alpha

    hj <- -(log(sum.j / sum..) + 1)
    alphaj <- as.numeric(hj %*% sum.j) / (sum.. * sum..)
    G2 <- matrix(hj, nRow, nCol, byrow = TRUE) / sum.. - alphaj

    hi <- -(log(sumi. / sum..) + 1)
    alphai <- as.numeric(sumi. %*% hi) / (sum.. * sum..)
    G3 <- matrix(hi, nRow, nCol) / sum.. - alphai

    attr(out, "grad") <- 2 * LAMBDA * (G1 - G2 - G3)
  }

  out
}

# oblimax
# Harman, 1976; Saunders, 1961
#
# for orthogonal rotation, oblimax is equivalent to quartimax
lav_matrix_rotate_oblimax <- function(LAMBDA = NULL, ..., grad = FALSE) {
  L2 <- LAMBDA * LAMBDA

  # minimize version
  out <- -log(sum(L2 * L2)) + 2 * log(sum(L2))

  if (grad) {
    attr(out, "grad") <- (-4 * L2 * LAMBDA / (sum(L2 * L2))
      + 4 * LAMBDA / (sum(L2)))
  }

  out
}

# Bentler's Invariant Pattern Simplicity
# Bentler (1977)
#
#
lav_matrix_rotate_bentler <- function(LAMBDA = NULL, ..., grad = FALSE) {
  L2 <- LAMBDA * LAMBDA

  L2tL2 <- crossprod(L2)
  L2tL2.inv <- lav_matrix_symmetric_inverse(S = L2tL2, logdet = TRUE)
  L2tL2.logdet <- attr(L2tL2.inv, "logdet")

  DIag <- diag(L2tL2)
  DIag.inv <- diag(1 / DIag)
  DIag.logdet <- sum(log(DIag)) # add small constant?

  # minimize version
  out <- -(L2tL2.logdet - DIag.logdet) / 4

  if (grad) {
    attr(out, "grad") <- -LAMBDA * (L2 %*% (L2tL2.inv - DIag.inv))
  }

  out
}


# The Tandem criteria
# Comrey (1967)
#
# only for sequential use:
# - tandem1 is used to determine the number of factors
#   (it removes the minor factors)
# - tandomII is used for final rotation
#
lav_matrix_rotate_tandem1 <- function(LAMBDA, ..., grad = FALSE) {
  L2 <- LAMBDA * LAMBDA
  LL <- tcrossprod(LAMBDA)
  LL2 <- LL * LL

  # minimize version
  out <- -1 * sum(L2 * (LL2 %*% L2))

  if (grad) {
    tmp1 <- 4 * LAMBDA * (LL2 %*% L2)
    tmp2 <- 4 * (LL * (L2 %*% t(L2))) %*% LAMBDA
    attr(out, "grad") <- -tmp1 - tmp2
  }

  out
}

lav_matrix_rotate_tandem2 <- function(LAMBDA, ..., grad = FALSE) {
  L2 <- LAMBDA * LAMBDA
  LL <- tcrossprod(LAMBDA)
  LL2 <- LL * LL

  # minimize version
  out <- sum(L2 * ((1 - LL2) %*% L2))

  if (grad) {
    tmp1 <- 4 * LAMBDA * ((1 - LL2) %*% L2)
    tmp2 <- 4 * (LL * tcrossprod(L2, L2)) %*% LAMBDA
    attr(out, "grad") <- tmp1 - tmp2
  }

  out
}


# simplimax
# Kiers (1994)
#
# oblique rotation method
# designed to rotate so that a given number 'k' of small loadings are
# as close to zero as possible
#
# may be viewed as partially specified target rotation with
# dynamically chosen weights
#
lav_matrix_rotate_simplimax <- function(LAMBDA = NULL, k = nrow(LAMBDA),
                                        ..., grad = FALSE) {
  L2 <- LAMBDA * LAMBDA

  # 'k' smallest element of L2
  small.element <- sort(L2)[k]

  # which elements are smaller than (or equal than) 'small.element'?
  ID <- sign(L2 <= small.element)

  # minimize version
  out <- sum(L2 * ID)

  if (grad) {
    attr(out, "grad") <- 2 * ID * LAMBDA
  }

  out
}


# target rotation
# Harman, 1976
#
# LAMBDA is rotated toward a specified target matrix 'target'
#
# Note: 'target' must be fully specified; if there are any NAs
#        use lav_matrix_rotate_pst() instead
#
lav_matrix_rotate_target <- function(LAMBDA = NULL, target = NULL,
                                     ..., grad = FALSE) {
  # squared difference
  DIFF <- LAMBDA - target
  DIFF2 <- DIFF * DIFF

  out <- sum(DIFF2, na.rm = TRUE)

  if (grad) {
    tmp <- 2 * DIFF
    # change NAs to zero
    tmp[is.na(tmp)] <- 0
    attr(out, "grad") <- tmp
  }

  out
}

# partially specified target rotation
#
# Browne 1972a, 1972b
#
# a pre-specified weight matrix W with ones/zeroes determines
# which elements of (LAMBDA - target) are used by the rotation criterion
#
# if 'target' contains NAs, they should correspond to '0' values in the
# target.mask matrix
#
lav_matrix_rotate_pst <- function(LAMBDA = NULL, target = NULL,
                                  target.mask = NULL, ..., grad = FALSE) {
  # mask target+LAMBDA
  target <- target.mask * target
  LAMBDA <- target.mask * LAMBDA

  # squared difference
  DIFF <- LAMBDA - target
  DIFF2 <- DIFF * DIFF

  # minimize
  out <- sum(DIFF2, na.rm = TRUE)

  if (grad) {
    tmp <- 2 * DIFF
    # change NAs to zero
    tmp[is.na(tmp)] <- 0
    attr(out, "grad") <- tmp
  }

  out
}


# bi-quartimin
#
# Jennrich & Bentler 2011
#
lav_matrix_rotate_biquartimin <- function(LAMBDA, ..., grad = FALSE) {
  # see Matlab code page 549
  stopifnot(ncol(LAMBDA) > 1L)

  # remove first column
  LAMBDA.group <- LAMBDA[, -1, drop = FALSE]

  # apply quartimin on the 'group' part
  out <- lav_matrix_rotate_quartimin(LAMBDA.group, ..., grad = grad)

  if (grad) {
    tmp <- attr(out, "grad")
    attr(out, "grad") <- cbind(0, tmp)
  }

  out
}


# bi-geomin
#
# Jennrich & Bentler 2012
#
lav_matrix_rotate_bigeomin <- function(LAMBDA, geomin.epsilon = 0.01, ...,
                                       grad = FALSE) {
  stopifnot(ncol(LAMBDA) > 1L)

  # remove first column
  LAMBDA.group <- LAMBDA[, -1, drop = FALSE]

  # apply geomin on the 'group' part
  out <- lav_matrix_rotate_geomin(LAMBDA.group,
    geomin.epsilon = geomin.epsilon, ...,
    grad = grad
  )

  if (grad) {
    tmp <- attr(out, "grad")
    attr(out, "grad") <- cbind(0, tmp)
  }

  out
}

# multiple group rotation + agreement
lav_matrix_rotate_mg_agreement <- function(lambdaList, method.fname = "geomin",
                                   method.args = list(),
                                   mg.agreement.method = "procrustes",
                                   w = 0.5, scale = TRUE) {
  ngroups <- length(lambdaList)

  # 0. rescale, so all columns have the same (average) sum-of-squares
  if (scale) {
    SS.LIST <- lapply(lambdaList, function(x) colSums(x * x))
    SS.ave <- Reduce("+", SS.LIST) / length(SS.LIST)
    for (g in seq_len(ngroups)) {
      lambdaList[[g]] <- t(t(lambdaList[[g]]) / sqrt(SS.LIST[[g]]) * sqrt(SS.ave))
    }
  }

  # 1. simple structure crit for each group
  Q.group <- numeric(ngroups)
  for (g in seq_len(ngroups)) {
    Q.group[g] <- do.call(method.fname, c(
      list(LAMBDA = lambdaList[[g]]),
      method.args, list(grad = FALSE)
    ))
  }
  # FIXME: should we 'weight' the groups, based on sample size?
  Q.mg <- sum(Q.group)

  # 2. agreement (generalized procrustes) across all groups
  if (mg.agreement.method == "procrustes") {
    A.mg <- 0
    pairs <- utils::combn(seq_len(ngroups), 2L)
    for (p in seq_len(ncol(pairs))) {
      g1 <- pairs[1L, p]
      g2 <- pairs[2L, p]
      diff <- (lambdaList[[g1]] - lambdaList[[g2]])
      diff2 <- diff * diff
      # FiXME: should we 'weight' the groups, based on sample size?
      A.mg <- A.mg + sum(diff2)
    }
  } else {
    lav_msg_stop(gettext("only mg.agreement.method procrustes is supported for now"))
  }

  out <- (w * A.mg) + ((1 - w) * Q.mg)

  attr(out, "Q.mg") <- Q.mg
  attr(out, "A.mg") <- A.mg

  out
}

# gradient check
ilav_matrix_rotate_grad_test <- function(crit = NULL, ...,
                                         LAMBDA = NULL,
                                         nRow = 20L, nCol = 5L) {
  # test matrix
  if (is.null(LAMBDA)) {
    LAMBDA <- matrix(rnorm(nRow * nCol), nRow, nCol)
  }

  ff <- function(x, ...) {
    Lambda <- matrix(x, nRow, nCol)
    crit(Lambda, ..., grad = FALSE)
  }

  GQ1 <- matrix(
    numDeriv::grad(func = ff, x = as.vector(LAMBDA), ...),
    nRow, nCol
  )
  GQ2 <- attr(crit(LAMBDA, ..., grad = TRUE), "grad")

  if (lav_verbose()) {
    print(list(LAMBDA = LAMBDA, GQ1 = GQ1, GQ2 = GQ2))
  }

  all.equal(GQ1, GQ2, tolerance = 1e-07)
}

ilav_matrix_rotate_grad_test_all <- function() {
  # Orthomax family with various values for gamma
  for (gamma in seq(0, 1, 0.2)) {
    check <- ilav_matrix_rotate_grad_test(
      crit = lav_matrix_rotate_orthomax,
      gamma = gamma
    )
    if (is.logical(check) && check) {
      cat(
        "orthomax + gamma = ", sprintf("%3.1f", gamma),
        ": OK\n"
      )
    } else {
      cat(
        "orthomax + gamma = ", sprintf("%3.1f", gamma),
        ": FAILED\n"
      )
    }
  }

  # Crawford-Ferguson with various values for gamma
  for (gamma in seq(0, 1, 0.2)) {
    check <- ilav_matrix_rotate_grad_test(
      crit = lav_matrix_rotate_cf,
      gamma = gamma
    )
    if (is.logical(check) && check) {
      cat(
        "Crawford-Ferguson + gamma = ", sprintf("%3.1f", gamma),
        ": OK\n"
      )
    } else {
      cat(
        "Crawford-Ferguson + gamma = ", sprintf("%3.1f", gamma),
        ": FAILED\n"
      )
    }
  }

  # Oblimin family with various values for gamma
  for (gamma in seq(0, 1, 0.2)) {
    check <- ilav_matrix_rotate_grad_test(
      crit = lav_matrix_rotate_oblimin,
      gamma = gamma
    )
    if (is.logical(check) && check) {
      cat(
        "Oblimin + gamma = ", sprintf("%3.1f", gamma),
        ": OK\n"
      )
    } else {
      cat(
        "Oblimin + gamma = ", sprintf("%3.1f", gamma),
        ": FAILED\n"
      )
    }
  }

  # quartimax
  check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_quartimax)
  if (is.logical(check) && check) {
    cat("quartimax: OK\n")
  } else {
    cat("quartimax: FAILED\n")
  }

  # varimax
  check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_varimax)
  if (is.logical(check) && check) {
    cat("varimax: OK\n")
  } else {
    cat("varimax: FAILED\n")
  }

  # quartimin
  check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_quartimin)
  if (is.logical(check) && check) {
    cat("quartimin: OK\n")
  } else {
    cat("quartimin: FAILED\n")
  }

  # geomin
  check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_geomin)
  if (is.logical(check) && check) {
    cat("geomin: OK\n")
  } else {
    cat("geomin: FAILED\n")
  }

  # simple entropy
  check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_entropy)
  if (is.logical(check) && check) {
    cat("entropy: OK\n")
  } else {
    cat("entropy: FAILED\n")
  }

  # McCammon entropy criterion
  check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_mccammon)
  if (is.logical(check) && check) {
    cat("McCammon: OK\n")
  } else {
    cat("McCammon: FAILED\n")
  }

  # infomax
  check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_infomax)
  if (is.logical(check) && check) {
    cat("infomax: OK\n")
  } else {
    cat("infomax: FAILED\n")
  }

  # oblimax
  check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_oblimax)
  if (is.logical(check) && check) {
    cat("oblimax: OK\n")
  } else {
    cat("oblimax: FAILED\n")
  }

  # bentler
  check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_bentler)
  if (is.logical(check) && check) {
    cat("bentler: OK\n")
  } else {
    cat("bentler: FAILED\n")
  }

  # simplimax
  check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_simplimax)
  if (is.logical(check) && check) {
    cat("simplimax: OK\n")
  } else {
    cat("simplimax: FAILED\n")
  }

  # tandem1
  check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_tandem1)
  if (is.logical(check) && check) {
    cat("tandem1: OK\n")
  } else {
    cat("tandem1: FAILED\n")
  }

  # tandem2
  check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_tandem2)
  if (is.logical(check) && check) {
    cat("tandem2: OK\n")
  } else {
    cat("tandem2: FAILED\n")
  }

  # bi-quartimin
  check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_biquartimin)
  if (is.logical(check) && check) {
    cat("biquartimin: OK\n")
  } else {
    cat("biquartimin: FAILED\n")
  }

  # bi-quartimin
  check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_bigeomin)
  if (is.logical(check) && check) {
    cat("bigeomin: OK\n")
  } else {
    cat("bigeomin: FAILED\n")
  }
}

# construct 1D, 2D or pattern-based frequency tables
# YR. 10 April 2013
# Notes:
# - we do NOT make a distinction here between unordered and ordered categorical
#   variables
# - object can be a matrix (most likely with integers), a full data frame,
#   a fitted lavaan object, or a lavData object
# - 11 May 2013: added collapse=TRUE, min.std.resid options (suggested
#   by Myrsini Katsikatsou
# - 11 June 2013: added dimension, to get one-way and two-way (three-way?)
#   tables
# - 20 Sept 2013: - allow for sample-based or model-based cell probabilities
#                   re-organize/re-name to provide a more consistent interface
#                   rows in the output can be either: cells, tables or patterns
#                 - dimension=0 equals type="pattern
#                 - collapse=TRUE is replaced by type="table"
#                 - changed names of statistics: std.resid is now GR.average
#                 - added many more statistics; some based on the model, some
#                   on the unrestricted model
# - 8 Nov 2013:   - skip empty cells for G2, instead of adding 0.5 to obs
# - 7 Feb 2016:   - take care of conditional.x = TRUE

lavTables <- function(object,
                      # what type of table?
                      dimension = 2L,
                      type = "cells",
                      # if raw data, additional attributes
                      categorical = NULL,
                      group = NULL,
                      # which statistics / fit indices?
                      statistic = "default",
                      G2.min = 3.0, # needed for G2.{p/n}large
                      X2.min = 3.0, # needed for X2.{p/n}large
                      # pvalues for statistics?
                      p.value = FALSE,
                      # Bonferonni
                      # alpha.adj    = FALSE,
                      # output format
                      output = "data.frame",
                      patternAsString = TRUE) {
  # check object
  object <- lav_object_check_version(object)

  # check input
  if (!(dimension == 0L || dimension == 1L || dimension == 2L)) {
    lav_msg_stop(gettext(
      "dimension must be 0, 1 or 2 for pattern, one-way or two-way tables"))
  }
  stopifnot(type %in% c("cells", "table", "pattern"))
  if (type == "pattern") {
    dimension <- 0L
  }

  # extract or create lavdata
  lavdata <- lav_lavdata(object, ordered = categorical, group = group)

  # is 'object' a lavaan object?
  lavobject <- NULL
  if (inherits(object, "lavaan")) {
    lavobject <- object
  }

  # case 1: response patterns
  if (dimension == 0L) {
    out <- lav_tables_pattern(
      lavobject = lavobject, lavdata = lavdata,
      statistic = statistic,
      patternAsString = patternAsString
    )
    # output format
    if (output == "data.frame") {
      class(out) <- c("lavaan.data.frame", "data.frame")
    } else {
      lav_msg_warn(gettextf("output option `%s' is not available; ignored.",
                            output))
    }

    # case 2: one-way/univariate
  } else if (dimension == 1L) {
    out <- lav_tables_oneway(
      lavobject = lavobject, lavdata = lavdata,
      statistic = statistic
    )

    # output format
    if (output == "data.frame") {
      class(out) <- c("lavaan.data.frame", "data.frame")
    } else {
      lav_msg_warn(gettextf("output option `%s' is not available; ignored.",
                            output))
    }

    # case 3a: two-way/pairwise/bivariate + cells
  } else if (dimension == 2L && type == "cells") {
    out <- lav_tables_pairwise_cells(
      lavobject = lavobject,
      lavdata = lavdata,
      statistic = statistic
    )
    # output format
    if (output == "data.frame") {
      class(out) <- c("lavaan.data.frame", "data.frame")
    } else if (output == "table") {
      out <- lav_tables_cells_format(out, lavdata = lavdata)
    } else {
      lav_msg_warn(gettextf("output option `%s' is not available; ignored.",
                            output))
    }

    #  case 3b: two-way/pairwise/bivariate + collapsed table
  } else if (dimension == 2L && (type == "table" || type == "tables")) {
    out <- lav_tables_pairwise_table(
      lavobject = lavobject,
      lavdata = lavdata,
      statistic = statistic,
      G2.min = G2.min,
      X2.min = X2.min,
      p.value = p.value
    )
    # output format
    if (output == "data.frame") {
      class(out) <- c("lavaan.data.frame", "data.frame")
    } else if (output == "table") {
      out <- lav_tables_table_format(out,
        lavdata = lavdata,
        lavobject = lavobject
      )
    } else {
      lav_msg_warn(gettext("output option `%s' is not available; ignored.",
                           output))
    }
  }

  if ((is.data.frame(out) && nrow(out) == 0L) ||
    (is.list(out) && length(out) == 0L)) {
    # empty table (perhaps, no categorical variables)
    return(invisible(out))
  }

  out
}

# shortcut, always dim=2, type="cells"
# lavTablesFit <- function(object,
#                         # if raw data, additional attributes
#                         categorical  = NULL,
#                         group        = NULL,
#                         # which statistics / fit indices?
#                         statistic    = "default",
#                         G2.min       = 3.0,
#                         X2.min       = 3.0,
#                         # pvalues for statistics?
#                         p.value      = FALSE,
#                         # output format
#                         output       = "data.frame") {
#
#    lavTables(object = object, dimension = 2L, type = "table",
#              categorical = categorical, group = group,
#              statistic = statistic,
#              G2.min = G2.min, X2.min = X2.min, p.value = p.value,
#              output = output, patternAsString = FALSE)
# }

# lavTables1D <- function(object,
#                        # if raw data, additional attributes
#                        categorical  = NULL,
#                       group        = NULL,
#                       # which statistics / fit indices?
#                        statistic    = "default",
#                        # output format
#                        output = "data.frame") {
#
#   lavTables(object = object, dimension = 1L,
#              categorical = categorical, group = group,
#              statistic = statistic, p.value = FALSE,
#              output = output, patternAsString = FALSE)
# }


lav_tables_pattern <- function(lavobject = NULL, lavdata = NULL,
                               statistic = NULL, patternAsString = TRUE) {
  # this only works if we have 'categorical' variables
  cat.idx <- which(lavdata@ov$type %in% c("ordered", "factor"))
  if (length(cat.idx) == 0L) {
    lav_msg_warn(gettext("no categorical variables are found"))
    return(data.frame(
      pattern = character(0L), nobs = integer(0L),
      obs.freq = integer(0L), obs.prop = numeric(0L)
    ))
  }
  # no support yet for mixture of endogenous ordered + numeric variables
  if (!is.null(lavobject) &&
    length(lav_object_vnames(lavobject, "ov.nox")) > length(cat.idx)) {
    lav_msg_warn(gettext("some endogenous variables are not categorical"))
    return(data.frame(
      pattern = character(0L), nobs = integer(0L),
      obs.freq = integer(0L), obs.prop = numeric(0L)
    ))
  }

  # default statistics
  if (!is.null(lavobject)) {
    if (length(statistic) == 1L && statistic == "default") {
      statistic <- c("G2", "X2")
    } else {
      stopifnot(statistic %in% c("G2.un", "X2.un", "G2", "X2"))
    }
  } else {
    # only data
    if (length(statistic) == 1L && statistic == "default") {
      # if data, none by default
      statistic <- character(0L)
    } else {
      stopifnot(statistic %in% c("G2.un", "X2.un"))
    }
  }

  # first, create basic table with response patterns
  for (g in 1:lavdata@ngroups) {
    pat <- lav_data_resp_patterns(lavdata@X[[g]])$pat
    obs.freq <- as.integer(rownames(pat))
    if (patternAsString) {
      pat <- data.frame(
        pattern = apply(pat, 1, paste, collapse = ""),
        stringsAsFactors = FALSE
      )
    } else {
      pat <- as.data.frame(pat, stringsAsFactors = FALSE)
      names(pat) <- lavdata@ov.names[[g]]
    }
    # pat$id <- 1:nrow(pat)
    if (lavdata@ngroups > 1L) {
      pat$group <- rep(g, nrow(pat))
    }
    NOBS <- sum(obs.freq)
    pat$nobs <- rep(NOBS, nrow(pat))
    pat$obs.freq <- obs.freq
    rownames(pat) <- NULL
    if (g == 1L) {
      out <- pat
    } else {
      out <- rbind(out, pat)
    }
  }

  out$obs.prop <- out$obs.freq / out$nobs

  if (any(c("X2.un", "G2.un") %in% statistic)) {
    # not a good statistic... we only have uni+bivariate information
    lav_msg_warn(gettext(
      "limited information used for thresholds and correlations;
      but X2/G2 assumes full information"))
    PI <- lav_tables_resp_pi(
      lavobject = lavobject, lavdata = lavdata,
      est = "h1"
    )

    out$est.prop.un <- unlist(PI)
    if ("G2.un" %in% statistic) {
      out$G2.un <- lav_tables_stat_G2(
        out$obs.prop, out$est.prop.un,
        out$nobs
      )
    }
    if ("X2.un" %in% statistic) {
      out$X2.un <- lav_tables_stat_X2(
        out$obs.prop, out$est.prop.un,
        out$nobs
      )
    }
  }
  if (any(c("X2", "G2") %in% statistic)) {
    if (lavobject@Options$estimator %in% c("FML")) {
      # ok, nothing to say
    } else if (lavobject@Options$estimator %in%
      c("WLS", "DWLS", "PML", "ULS")) {
      lav_msg_warn(gettextf(
        "estimator %s is not using full information while est.prop is
        using full information", lavobject@Options$estimator))
    } else {
      lav_msg_stop(gettextf(
        "estimator %s is not supported.", lavobject@Options$estimator))
    }

    PI <- lav_tables_resp_pi(
      lavobject = lavobject, lavdata = lavdata,
      est = "h0"
    )

    out$est.prop <- unlist(PI)
    if ("G2" %in% statistic) {
      out$G2 <- lav_tables_stat_G2(
        out$obs.prop, out$est.prop,
        out$nobs
      )
    }
    if ("X2" %in% statistic) {
      out$X2 <- lav_tables_stat_X2(
        out$obs.prop, out$est.prop,
        out$nobs
      )
    }
  }

  # remove nobs?
  # out$nobs <- NULL

  out
}

# pairwise tables, rows = table cells
lav_tables_pairwise_cells <- function(lavobject = NULL, lavdata = NULL,
                                      statistic = character(0L)) {
  # this only works if we have at least two 'categorical' variables
  cat.idx <- which(lavdata@ov$type %in% c("ordered", "factor"))
  if (length(cat.idx) == 0L) {
    lav_msg_warn(gettext("no categorical variables are found"))
    return(data.frame(
      id = integer(0L), lhs = character(0L), rhs = character(0L),
      nobs = integer(0L), row = integer(0L), col = integer(0L),
      obs.freq = integer(0L), obs.prop = numeric(0L)
    ))
  }
  if (length(cat.idx) == 1L) {
    lav_msg_warn(gettext("at least two categorical variables are needed"))
    return(data.frame(
      id = integer(0L), lhs = character(0L), rhs = character(0L),
      nobs = integer(0L), row = integer(0L), col = integer(0L),
      obs.freq = integer(0L), obs.prop = numeric(0L)
    ))
  }

  # default statistics
  if (!is.null(lavobject)) {
    if (length(statistic) == 1L && statistic == "default") {
      statistic <- c("X2")
    } else {
      stopifnot(statistic %in% c(
        "cor", "th", "X2", "G2",
        "cor.un", "th.un", "X2.un", "G2.un"
      ))
    }
  } else {
    if (length(statistic) == 1L && statistic == "default") {
      # if data, none by default
      statistic <- character(0L)
    } else {
      stopifnot(statistic %in% c("cor.un", "th.un", "X2.un", "G2.un"))
    }
  }

  # initial table, observed cell frequencies
  out <- lav_tables_pairwise_freq_cell(
    lavdata = lavdata,
    as.data.frame. = TRUE
  )
  out$obs.prop <- out$obs.freq / out$nobs

  if (any(c("cor.un", "th.un", "X2.un", "G2.un") %in% statistic)) {
    PI <- lav_tables_pairwise_sample_pi(
      lavobject = lavobject,
      lavdata = lavdata
    )
    out$est.prop.un <- unlist(PI)
    if ("G2.un" %in% statistic) {
      out$G2.un <- lav_tables_stat_G2(
        out$obs.prop, out$est.prop.un,
        out$nobs
      )
    }
    if ("X2.un" %in% statistic) {
      out$X2.un <- lav_tables_stat_X2(
        out$obs.prop, out$est.prop.un,
        out$nobs
      )
    }

    if ("cor.un" %in% statistic) {
      COR <- attr(PI, "COR")
      cor.all <- unlist(lapply(COR, function(x) {
        x[lower.tri(x, diag = FALSE)]
      }))
      out$cor.un <- cor.all[out$id]
    }
  }
  if (any(c("cor", "th", "X2", "G2") %in% statistic)) {
    PI <- lav_tables_pairwise_model_pi(lavobject = lavobject)
    out$est.prop <- unlist(PI)
    if ("G2" %in% statistic) {
      out$G2 <- lav_tables_stat_G2(
        out$obs.prop, out$est.prop,
        out$nobs
      )
    }
    if ("X2" %in% statistic) {
      out$X2 <- lav_tables_stat_X2(
        out$obs.prop, out$est.prop,
        out$nobs
      )
    }
    if ("cor" %in% statistic) {
      COR <- attr(PI, "COR")
      cor.all <- unlist(lapply(COR, function(x) {
        x[lower.tri(x, diag = FALSE)]
      }))
      out$cor <- cor.all[out$id]
    }
  }

  out
}

# G2 statistic
lav_tables_stat_G2 <- function(obs.prop = NULL, est.prop = NULL, nobs = NULL) {
  # not defined if out$obs.prop is (close to) zero
  zero.idx <- which(obs.prop < .Machine$double.eps)
  if (length(zero.idx)) {
    obs.prop[zero.idx] <- as.numeric(NA)
  }
  # the usual G2 formula
  G2 <- 2 * nobs * (obs.prop * log(obs.prop / est.prop))
  G2
}

# X2 (aka X2) statistic
lav_tables_stat_X2 <- function(obs.prop = NULL, est.prop = NULL, nobs = NULL) {
  res.prop <- obs.prop - est.prop
  X2 <- nobs * (res.prop * res.prop) / est.prop
  X2
}

# pairwise tables, rows = tables
lav_tables_pairwise_table <- function(lavobject = NULL, lavdata = NULL,
                                      statistic = character(0L),
                                      G2.min = 3.0,
                                      X2.min = 3.0,
                                      p.value = FALSE) {
  # default statistics
  if (!is.null(lavobject)) {
    if (length(statistic) == 1L && statistic == "default") {
      statistic <- c("X2", "X2.average")
    } else {
      stopifnot(statistic %in% c(
        "X2", "G2", "X2.un", "G2.un",
        "cor", "cor.un",
        "RMSEA.un", "RMSEA",
        "G2.average",
        "G2.nlarge",
        "G2.plarge",
        "X2.average",
        "X2.nlarge",
        "X2.plarge"
      ))
    }
  } else {
    if (length(statistic) == 1L && statistic == "default") {
      # if data, none by default
      statistic <- character(0L)
    } else {
      stopifnot(statistic %in% c(
        "cor.un", "X2.un", "G2.un",
        "RMSEA.un"
      ))
    }
  }

  # identify 'categorical' variables
  # cat.idx <- which(lavdata@ov$type %in% c("ordered","factor"))

  # pairwise tables
  # pairwise.tables <- utils::combn(vartable$name[cat.idx], m=2L)
  # pairwise.tables <- rbind(seq_len(ncol(pairwise.tables)),
  #                         pairwise.tables)
  # ntables <- ncol(pairwise.tables)

  # initial table, observed cell frequencies
  # out <- as.data.frame(t(pairwise.tables))
  # names(out) <- c("id", "lhs", "rhs")

  # collapse approach
  stat.cell <- character(0)
  if (any(c("G2", "G2.average", "G2.plarge", "G2.nlarge") %in% statistic)) {
    stat.cell <- c(stat.cell, "G2")
  }
  if (any(c("X2", "X2.average", "X2.plarge", "X2.nlarge") %in% statistic)) {
    stat.cell <- c(stat.cell, "X2")
  }
  if ("G2" %in% statistic || "RMSEA" %in% statistic) {
    stat.cell <- c(stat.cell, "G2")
  }
  if ("X2.un" %in% statistic) {
    stat.cell <- c(stat.cell, "X2.un")
  }
  if ("G2.un" %in% statistic || "RMSEA.un" %in% statistic) {
    stat.cell <- c(stat.cell, "G2.un")
  }
  if ("cor.un" %in% statistic) {
    stat.cell <- c(stat.cell, "cor.un")
  }
  if ("cor" %in% statistic) {
    stat.cell <- c(stat.cell, "cor")
  }

  # get table with table cells
  out.cell <- lav_tables_pairwise_cells(
    lavobject = lavobject,
    lavdata = lavdata,
    statistic = stat.cell
  )
  # only 1 row per table
  row.idx <- which(!duplicated(out.cell$id))
  if (is.null(out.cell$group)) {
    out <- out.cell[row.idx, c("lhs", "rhs", "nobs"), drop = FALSE]
  } else {
    out <- out.cell[row.idx, c("lhs", "rhs", "group", "nobs"), drop = FALSE]
  }

  # df
  if (length(statistic) > 0L) {
    nrow <- tapply(out.cell$row, INDEX = out.cell$id, FUN = max)
    ncol <- tapply(out.cell$col, INDEX = out.cell$id, FUN = max)
    out$df <- nrow * ncol - nrow - ncol
  }

  # cor
  if ("cor" %in% statistic) {
    out$cor <- out.cell[row.idx, "cor"]
  }

  # cor.un
  if ("cor.un" %in% statistic) {
    out$cor.un <- out.cell[row.idx, "cor.un"]
  }

  # X2
  if ("X2" %in% statistic) {
    out$X2 <- tapply(out.cell$X2,
      INDEX = out.cell$id, FUN = sum,
      na.rm = TRUE
    )
    if (p.value) {
      out$X2.pval <- pchisq(out$X2, df = out$df, lower.tail = FALSE)
    }
  }
  if ("X2.un" %in% statistic) {
    out$X2.un <- tapply(out.cell$X2.un,
      INDEX = out.cell$id, FUN = sum,
      na.rm = TRUE
    )
    if (p.value) {
      out$X2.un.pval <- pchisq(out$X2.un, df = out$df, lower.tail = FALSE)
    }
  }

  # G2
  if ("G2" %in% statistic) {
    out$G2 <- tapply(out.cell$G2,
      INDEX = out.cell$id, FUN = sum,
      na.rm = TRUE
    )
    if (p.value) {
      out$G2.pval <- pchisq(out$G2, df = out$df, lower.tail = FALSE)
    }
  }
  if ("G2.un" %in% statistic) {
    out$G2.un <- tapply(out.cell$G2.un,
      INDEX = out.cell$id, FUN = sum,
      na.rm = TRUE
    )
    if (p.value) {
      out$G2.un.pval <- pchisq(out$G2.un, df = out$df, lower.tail = FALSE)
    }
  }

  if ("RMSEA" %in% statistic) {
    G2 <- tapply(out.cell$G2, INDEX = out.cell$id, FUN = sum, na.rm = TRUE)
    # note: there seems to be a mistake in Appendix 1 eqs 43/44 of Joreskog
    # SSI paper (2005) 'SEM with ordinal variables using LISREL'
    # 2*N*d should N*d
    out$RMSEA <- sqrt(pmax(0, (G2 - out$df) / (out$nobs * out$df)))
    if (p.value) {
      # note: MUST use 1 - pchisq (instead of lower.tail = FALSE)
      # because for ncp > 80, routine only computes lower tail
      out$RMSEA.pval <- 1.0 - pchisq(G2,
        ncp = 0.1 * 0.1 * out$nobs * out$df,
        df = out$df, lower.tail = TRUE
      )
    }
  }
  if ("RMSEA.un" %in% statistic) {
    G2 <- tapply(out.cell$G2.un,
      INDEX = out.cell$id, FUN = sum,
      na.rm = TRUE
    )
    # note: there seems to be a mistake in Appendix 1 eqs 43/44 of Joreskog
    # SSI paper (2005) 'SEM with ordinal variables using LISREL'
    # 2*N*d should N*d
    out$RMSEA.un <- sqrt(pmax(0, (G2 - out$df) / (out$nobs * out$df)))
    if (p.value) {
      # note: MUST use 1 - pchisq (instead of lower.tail = FALSE)
      # because for ncp > 80, routine only computes lower tail
      out$RMSEA.un.pval <- 1.0 - pchisq(G2,
        ncp = 0.1 * 0.1 * out$nobs * out$df,
        df = out$df, lower.tail = TRUE
      )
    }
  }

  if ("G2.average" %in% statistic) {
    out$G2.average <- tapply(out.cell$G2,
      INDEX = out.cell$id, FUN = mean,
      na.rm = TRUE
    )
  }

  if ("G2.nlarge" %in% statistic) {
    out$G2.min <- rep(G2.min, length(out$lhs))
    out$G2.nlarge <- tapply(out.cell$G2,
      INDEX = out.cell$id,
      FUN = function(x) sum(x > G2.min, na.rm = TRUE)
    )
  }

  if ("G2.plarge" %in% statistic) {
    out$G2.min <- rep(G2.min, length(out$lhs))
    out$G2.plarge <- tapply(out.cell$G2,
      INDEX = out.cell$id,
      FUN = function(x) sum(x > G2.min, na.rm = TRUE) / length(x)
    )
  }

  if ("X2.average" %in% statistic) {
    out$X2.average <- tapply(out.cell$X2,
      INDEX = out.cell$id, FUN = mean,
      na.rm = TRUE
    )
  }

  if ("X2.nlarge" %in% statistic) {
    out$X2.min <- rep(X2.min, length(out$lhs))
    out$X2.nlarge <- tapply(out.cell$X2,
      INDEX = out.cell$id,
      FUN = function(x) sum(x > X2.min, na.rm = TRUE)
    )
  }

  if ("X2.plarge" %in% statistic) {
    out$X2.min <- rep(X2.min, length(out$lhs))
    out$X2.plarge <- tapply(out.cell$X2,
      INDEX = out.cell$id,
      FUN = function(x) sum(x > X2.min, na.rm = TRUE) / length(x)
    )
  }

  out
}


lav_tables_oneway <- function(lavobject = NULL, lavdata = NULL,
                              statistic = NULL) {
  # shortcuts
  vartable <- lavdata@ov
  X <- lavdata@X

  # identify 'categorical' variables
  cat.idx <- which(vartable$type %in% c("ordered", "factor"))
  ncat <- length(cat.idx)

  # do we have any categorical variables?
  if (length(cat.idx) == 0L) {
    lav_msg_warn(gettext("no categorical variables are found"))
    return(data.frame(
      id = integer(0L), lhs = character(0L), rhs = character(0L),
      nobs = integer(0L),
      obs.freq = integer(0L), obs.prop = numeric(0L),
      est.prop = numeric(0L), X2 = numeric(0L)
    ))
  } else {
    labels <- strsplit(vartable$lnam[cat.idx], "\\|")
  }

  # ok, we have an overview of all categorical variables in the data
  ngroups <- length(X)

  # for each group, for each categorical variable, collect information
  TABLES <- vector("list", length = ngroups)
  for (g in 1:ngroups) {
    TABLES[[g]] <- lapply(seq_len(ncat),
      FUN = function(x) {
        idx <- cat.idx[x]
        nrow <- vartable$nlev[idx]
        ncell <- nrow
        nvar <- length(lavdata@ov.names[[g]])
        id <- (g - 1) * nvar + x

        # compute observed frequencies
        FREQ <- tabulate(X[[g]][, idx], nbins = ncell)

        list(
          id = rep.int(id, ncell),
          lhs = rep.int(vartable$name[idx], ncell),
          # op = rep.int("freq", ncell),
          rhs = labels[[x]],
          group = rep.int(g, ncell),
          nobs = rep.int(sum(FREQ), ncell),
          obs.freq = FREQ,
          obs.prop = FREQ / sum(FREQ)
        )
      }
    )
  }

  for (g in 1:ngroups) {
    TABLE <- TABLES[[g]]
    TABLE <- lapply(TABLE, as.data.frame, stringsAsFactors = FALSE)
    if (g == 1L) {
      out <- do.call(rbind, TABLE)
    } else {
      out <- rbind(out, do.call(rbind, TABLE))
    }
  }
  if (g == 1) {
    # remove group column
    out$group <- NULL
  }

  # default statistics
  if (!is.null(lavobject)) {
    if (length(statistic) == 1L && statistic == "default") {
      statistic <- c("X2")
    } else {
      stopifnot(statistic %in% c(
        "th.un",
        "th", "G2", "X2"
      ))
    }

    # sample based
    # note, there is no G2.un or X2.un: always saturated!
    if ("th.un" %in% statistic) {
      # sample based
      th <- unlist(lapply(1:lavdata@ngroups, function(x) {
        if (lavobject@Model@conditional.x) {
          TH <- lavobject@SampleStats@res.th[[x]][
            lavobject@SampleStats@th.idx[[x]] > 0
          ]
        } else {
          TH <- lavobject@SampleStats@th[[x]][
            lavobject@SampleStats@th.idx[[x]] > 0
          ]
        }
        TH.IDX <- lavobject@SampleStats@th.idx[[x]][
          lavobject@SampleStats@th.idx[[x]] > 0
        ]
        unname(unlist(tapply(TH,
          INDEX = TH.IDX,
          function(y) c(y, Inf)
        )))
      }))
      # overwrite obs.prop
      # NOTE: if we have exogenous variables, obs.prop will NOT
      #       correspond with qnorm(th)
      out$obs.prop <- unname(unlist(tapply(th,
        INDEX = out$id,
        FUN = function(x) {
          (pnorm(c(x, Inf)) -
            pnorm(c(-Inf, x)))[-(length(x) + 1)]
        }
      )))

      out$th.un <- th
    }

    # model based
    if (any(c("th", "G2", "X2") %in% statistic)) {
      # model based
      th.h0 <- unlist(lapply(1:lavdata@ngroups, function(x) {
        if (lavobject@Model@conditional.x) {
          TH <- lavobject@implied$res.th[[x]][
            lavobject@SampleStats@th.idx[[x]] > 0
          ]
        } else {
          TH <- lavobject@implied$th[[x]][
            lavobject@SampleStats@th.idx[[x]] > 0
          ]
        }
        TH.IDX <- lavobject@SampleStats@th.idx[[x]][
          lavobject@SampleStats@th.idx[[x]] > 0
        ]
        unname(unlist(tapply(TH,
          INDEX = TH.IDX,
          function(x) c(x, Inf)
        )))
      }))

      est.prop <- unname(unlist(tapply(th.h0,
        INDEX = out$id,
        FUN = function(x) {
          (pnorm(c(x, Inf)) -
            pnorm(c(-Inf, x)))[-(length(x) + 1)]
        }
      )))
      out$est.prop <- est.prop

      if ("th" %in% statistic) {
        out$th <- th.h0
      }
      if ("G2" %in% statistic) {
        out$G2 <- lav_tables_stat_G2(
          out$obs.prop, out$est.prop,
          out$nobs
        )
      }
      if ("X2" %in% statistic) {
        out$X2 <- lav_tables_stat_X2(
          out$obs.prop, out$est.prop,
          out$nobs
        )
      }
    }
  } else {
    if (length(statistic) == 1L && statistic == "default") {
      # if data, none by default
      statistic <- character(0L)
    } else {
      stopifnot(statistic %in% c("th.un"))
    }

    if ("th.un" %in% statistic) {
      out$th.un <- unlist(tapply(out$obs.prop,
        INDEX = out$id,
        FUN = function(x) qnorm(cumsum(x))
      ))
    }
  }

  out
}

# HJ 15/1/2023 MODIFIED to add sampling weights
# compute pairwise (two-way) frequency tables
lav_tables_pairwise_freq_cell <- function(lavdata = NULL,
                                          as.data.frame. = TRUE) {
  # shortcuts
  vartable <- as.data.frame(lavdata@ov, stringsAsFactors = FALSE)
  X <- lavdata@X
  ov.names <- lavdata@ov.names
  ngroups <- lavdata@ngroups
  wt <- lavdata@weights

  # identify 'categorical' variables
  cat.idx <- which(vartable$type %in% c("ordered", "factor"))

  # do we have any categorical variables?
  if (length(cat.idx) == 0L) {
    lav_msg_stop(gettext("no categorical variables are found"))
  } else if (length(cat.idx) == 1L) {
    lav_msg_stop(gettext("at least two categorical variables are needed"))
  }

  # pairwise tables
  pairwise.tables <- utils::combn(vartable$name[cat.idx], m = 2L)
  pairwise.tables <- rbind(pairwise.tables, seq_len(ncol(pairwise.tables)))
  ntables <- ncol(pairwise.tables)

  # for each group, for each pairwise table, collect information
  TABLES <- vector("list", length = ngroups)
  for (g in 1:ngroups) {
    TABLES[[g]] <- apply(pairwise.tables,
      MARGIN = 2,
      FUN = function(x) {
        idx1 <- which(vartable$name == x[1])
        idx2 <- which(vartable$name == x[2])
        id <- (g - 1) * ntables + as.numeric(x[3])
        nrow <- vartable$nlev[idx1]
        ncol <- vartable$nlev[idx2]
        ncell <- nrow * ncol

        # compute two-way observed frequencies
        Y1 <- X[[g]][, idx1]
        Y2 <- X[[g]][, idx2]
        # FREQ <- table(Y1, Y2) # we loose missings; useNA is ugly
        FREQ <- lav_bvord_freq(Y1, Y2)

        # >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

        # If we want to use weighted frequencies we can use the code
        # below. However, it will probably make sense only when the
        # weights are normalised. If they're not, we may get quite ugly
        # and nonsensical numbers here. So for now, just keep the
        # lavtables as is (using non-weighted frequencies).
        #
        # FREQ <- lav_bvord_freq(Y1, Y2, wt[[g]])

        # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>


        list(
          id = rep.int(id, ncell),
          lhs = rep.int(x[1], ncell),
          # op = rep.int("table", ncell),
          rhs = rep.int(x[2], ncell),
          group = rep.int(g, ncell),
          nobs = rep.int(sum(FREQ), ncell),
          row = rep.int(seq_len(nrow), times = ncol),
          col = rep(seq_len(ncol), each = nrow),
          obs.freq = lav_matrix_vec(FREQ) # col by col!
        )
      }
    )
  }

  if (as.data.frame.) {
    for (g in 1:ngroups) {
      TABLE <- TABLES[[g]]
      TABLE <- lapply(TABLE, as.data.frame, stringsAsFactors = FALSE)
      if (g == 1) {
        out <- do.call(rbind, TABLE)
      } else {
        out <- rbind(out, do.call(rbind, TABLE))
      }
    }
    if (g == 1) {
      # remove group column
      out$group <- NULL
    }
  } else {
    if (ngroups == 1L) {
      out <- TABLES[[1]]
    } else {
      out <- TABLES
    }
  }

  out
}


# low-level function to compute expected proportions per cell
# object
lav_tables_pairwise_model_pi <- function(lavobject = NULL) {
  stopifnot(lavobject@Model@categorical)

  # shortcuts
  lavmodel <- lavobject@Model
  implied <- lavobject@implied
  ngroups <- lavobject@Data@ngroups
  ov.types <- lavobject@Data@ov$type
  th.idx <- lavobject@Model@th.idx
  Sigma.hat <- if (lavmodel@conditional.x) implied$res.cov else implied$cov
  TH <- if (lavmodel@conditional.x) implied$res.th else implied$th

  PI <- vector("list", length = ngroups)
  for (g in 1:ngroups) {
    Sigmahat <- Sigma.hat[[g]]
    cors <- Sigmahat[lower.tri(Sigmahat)]
    if (any(abs(cors) > 1)) {
      lav_msg_warn(gettext(
        "some model-implied correlations are larger than 1.0"))
    }
    nvar <- nrow(Sigmahat)

    # shortcut for all ordered - tablewise
    if (all(ov.types == "ordered") && !is.null(lavobject@Cache[[g]]$long)) {
      # FREQ.OBS <- c(FREQ.OBS, lavobject@Cache[[g]]$bifreq)
      long2 <- lav_pml_longvec_th_rho(
        no.x = nvar,
        all.thres = TH[[g]],
        index.var.of.thres = th.idx[[g]],
        rho.xixj = cors
      )
      # get expected probability per table, per pair
      PI[[g]] <- lav_pml_expprob_vec(
        ind.vec = lavobject@Cache[[g]]$long,
        th.rho.vec = long2
      )
    } else {
      PI.group <- integer(0)
      # order! first i, then j, lav_matrix_vec(table)!
      for (i in seq_len(nvar - 1L)) {
        for (j in (i + 1L):nvar) {
          if (ov.types[i] == "ordered" && ov.types[j] == "ordered") {
            PI.table <- lav_bvord_noexo_pi(
              rho = Sigmahat[i, j],
              th.y1 = TH[[g]][th.idx[[g]] == i],
              th.y2 = TH[[g]][th.idx[[g]] == j]
            )
            PI.group <- c(PI.group, lav_matrix_vec(PI.table))
          }
        }
      }
      PI[[g]] <- PI.group
    }
  } # g

  # add  COR/TH/TH.IDX
  attr(PI, "COR") <- Sigma.hat
  attr(PI, "TH") <- TH
  attr(PI, "TH.IDX") <- th.idx

  PI
}

# low-level function to compute expected proportions per cell
# using sample-based correlations + thresholds
#
# object can be either lavData or lavaan class
lav_tables_pairwise_sample_pi <- function(lavobject = NULL, lavdata = NULL) {
  # get COR, TH and th.idx
  if (!is.null(lavobject)) {
    if (lavobject@Model@conditional.x) {
      COR <- lavobject@SampleStats@res.cov
      TH <- lavobject@SampleStats@res.th
    } else {
      COR <- lavobject@SampleStats@cov
      TH <- lavobject@SampleStats@th
    }
    TH.IDX <- lavobject@SampleStats@th.idx
  } else if (!is.null(lavdata)) {
    fit.un <- lav_object_cor(object = lavdata, se = "none", output = "fit")
    if (fit.un@Model@conditional.x) {
      COR <- fit.un@SampleStats@res.cov
      TH <- fit.un@SampleStats@res.th
    } else {
      COR <- fit.un@SampleStats@cov
      TH <- fit.un@SampleStats@th
    }
    TH.IDX <- fit.un@SampleStats@th.idx
  } else {
    lav_msg_stop(gettext("both lavobject and lavdata are NULL"))
  }

  lav_tables_pairwise_sample_pi_cor(
    COR = COR, TH = TH,
    TH.IDX = TH.IDX
  )
}

# low-level function to compute expected proportions per cell
lav_tables_pairwise_sample_pi_cor <- function(COR = NULL, TH = NULL,
                                              TH.IDX = NULL) {
  ngroups <- length(COR)

  PI <- vector("list", length = ngroups)
  for (g in 1:ngroups) {
    Sigmahat <- COR[[g]]
    cors <- Sigmahat[lower.tri(Sigmahat)]
    if (any(abs(cors) > 1)) {
      lav_msg_warn(gettext(
        "some model-implied correlations are larger than 1.0"))
    }
    nvar <- nrow(Sigmahat)
    th.idx <- TH.IDX[[g]]

    # reconstruct ov.types
    ov.types <- rep("numeric", nvar)
    ord.idx <- unique(th.idx[th.idx > 0])
    ov.types[ord.idx] <- "ordered"

    PI.group <- integer(0)
    # order! first i, then j, lav_matrix_vec(table)!
    for (i in seq_len(nvar - 1L)) {
      for (j in (i + 1L):nvar) {
        if (ov.types[i] == "ordered" && ov.types[j] == "ordered") {
          PI.table <- lav_bvord_noexo_pi(
            rho = Sigmahat[i, j],
            th.y1 = TH[[g]][th.idx == i],
            th.y2 = TH[[g]][th.idx == j]
          )
          PI.group <- c(PI.group, lav_matrix_vec(PI.table))
        }
      }
    }
    PI[[g]] <- PI.group
  } # g

  # add  COR/TH/TH.IDX
  attr(PI, "COR") <- COR
  attr(PI, "TH") <- TH
  attr(PI, "TH.IDX") <- TH.IDX

  PI
}

# low-level function to compute expected proportions per PATTERN
# using sample-based correlations + thresholds
#
# object can be either lavData or lavaan class
#
# only valid if estimator = FML, POM or NOR
#
lav_tables_resp_pi <- function(lavobject = NULL, lavdata = NULL,
                               est = "h0") {
  # shortcuts
  if (!is.null(lavobject)) {
    lavmodel <- lavobject@Model
    implied <- lavobject@implied
  }
  ngroups <- lavdata@ngroups

  # h0 or unrestricted?
  if (est == "h0") {
    Sigma.hat <- if (lavmodel@conditional.x) implied$res.cov else implied$cov
    TH <- if (lavmodel@conditional.x) implied$res.th else implied$th
    TH.IDX <- lavobject@SampleStats@th.idx
  } else {
    if (is.null(lavobject)) {
      fit.un <- lav_object_cor(object = lavdata, se = "none", output = "fit")
      Sigma.hat <- if (fit.un@Model@conditional.x) fit.un@implied$res.cov else fit.un@implied$cov
      TH <- if (fit.un@Model@conditional.x) fit.un@implied$res.th else fit.un@implied$th
      TH.IDX <- fit.un@SampleStats@th.idx
    } else {
      if (lavobject@Model@conditional.x) {
        Sigma.hat <- lavobject@SampleStats@res.cov
        TH <- lavobject@SampleStats@res.th
      } else {
        Sigma.hat <- lavobject@SampleStats@cov
        TH <- lavobject@SampleStats@th
      }
      TH.IDX <- lavobject@SampleStats@th.idx
    }
  }

  PI <- vector("list", length = ngroups)
  for (g in 1:ngroups) {
    Sigmahat <- Sigma.hat[[g]]
    cors <- Sigmahat[lower.tri(Sigmahat)]
    if (any(abs(cors) > 1)) {
      lav_msg_warn(gettext(
        "some model-implied correlations are larger than 1.0"))
    }
    nvar <- nrow(Sigmahat)
    th.idx <- TH.IDX[[g]]
    MEAN <- rep(0, nvar)

    # reconstruct ov.types
    ov.types <- rep("numeric", nvar)
    ord.idx <- unique(th.idx[th.idx > 0])
    ov.types[ord.idx] <- "ordered"

    if (all(ov.types == "ordered")) {
      # get patterns ## FIXME GET it
      if (!is.null(lavdata@Rp[[g]]$pat)) {
        PAT <- lavdata@Rp[[g]]$pat
      } else {
        PAT <- lav_data_resp_patterns(lavdata@X[[g]])$pat
      }
      npatterns <- nrow(PAT)
      freq <- as.numeric(rownames(PAT))
      PI.group <- numeric(npatterns)
      TH.VAR <- lapply(
        1:nvar,
        function(x) c(-Inf, TH[[g]][th.idx == x], +Inf)
      )
      # FIXME!!! ok to set diagonal to 1.0?
      diag(Sigmahat) <- 1.0
      for (r in 1:npatterns) {
        # compute probability for each pattern
        lower <- sapply(1:nvar, function(x) TH.VAR[[x]][PAT[r, x]])
        upper <- sapply(1:nvar, function(x) TH.VAR[[x]][PAT[r, x] + 1L])
        # handle missing values
        na.idx <- which(is.na(PAT[r, ]))
        if (length(na.idx) > 0L) {
          lower <- lower[-na.idx]
          upper <- upper[-na.idx]
          MEAN.r <- MEAN[-na.idx]
          Sigmahat.r <- Sigmahat[-na.idx, -na.idx, drop = FALSE]
        } else {
          MEAN.r <- MEAN
          Sigmahat.r <- Sigmahat
        }
        PI.group[r] <- sadmvn(lower, upper,
          mean = MEAN.r,
          varcov = Sigmahat.r
        )
      }
    } else { # case-wise
      PI.group <- rep(as.numeric(NA), lavdata@nobs[[g]])
      lav_msg_warn(gettext("casewise PI not implemented"))
    }

    PI[[g]] <- PI.group
  } # g

  PI
}

lav_tables_table_format <- function(out, lavdata = lavdata,
                                    lavobject = lavobject) {
  # determine column we need
  NAMES <- names(out)
  stat.idx <- which(NAMES %in% c(
    "cor", "cor.un",
    "G2", "G2.un",
    "X2", "X2.un",
    "RMSEA", "RMSEA.un",
    "G2.average", "G2.plarge", "G2.nlarge",
    "X2.average", "X2.plarge", "X2.nlarge"
  ))
  if (length(stat.idx) == 0) {
    if (!is.null(out$obs.freq)) {
      stat.idx <- which(NAMES == "obs.freq")
    } else if (!is.null(out$nobs)) {
      stat.idx <- which(NAMES == "nobs")
    }
    UNI <- NULL
  } else if (length(stat.idx) > 1) {
    lav_msg_stop(gettext(
      "more than one statistic for table output:"),
      paste(NAMES[stat.idx], collapse = " ")
    )
  } else {
    # univariate version of same statistic
    if (NAMES[stat.idx] == "G2.average") {
      UNI <- lavTables(lavobject, dimension = 1L, statistic = "G2")
    } else if (NAMES[stat.idx] == "X2.average") {
      UNI <- lavTables(lavobject, dimension = 1L, statistic = "X2")
    } else {
      UNI <- NULL
    }
  }

  OUT <- vector("list", length = lavdata@ngroups)
  for (g in 1:lavdata@ngroups) {
    if (lavdata@ngroups == 1L) { # no group column
      STAT <- out[[stat.idx]]
    } else {
      STAT <- out[[stat.idx]][out$group == g]
    }
    RN <- lavdata@ov.names[[g]]
    OUT[[g]] <- lav_getcov(STAT, diagonal = FALSE, lower = FALSE, names = RN)
    # change diagonal elements: replace by univariate stat
    # if possible
    diag(OUT[[g]]) <- as.numeric(NA)
    if (!is.null(UNI)) {
      if (!is.null(UNI$group)) {
        idx <- which(UNI$group == g)
      } else {
        idx <- 1:length(UNI$lhs)
      }
      if (NAMES[stat.idx] == "G2.average") {
        diag(OUT[[g]]) <- tapply(UNI$G2[idx],
          INDEX = UNI$id[idx],
          FUN = mean
        )
      } else if (NAMES[stat.idx] == "X2.average") {
        diag(OUT[[g]]) <- tapply(UNI$X2[idx],
          INDEX = UNI$id[idx],
          FUN = mean
        )
      }
    } else if (NAMES[stat.idx] %in% c("cor", "cor.un")) {
      diag(OUT[[g]]) <- 1
    }
    class(OUT[[g]]) <- c("lavaan.matrix.symmetric", "matrix")
  }
  if (lavdata@ngroups > 1L) {
    names(OUT) <- lavdata@group.label
    out <- OUT
  } else {
    out <- OUT[[1]]
  }

  out
}

lav_tables_cells_format <- function(out, lavdata = lavdata,
                                    drop.list.single.group = FALSE) {
  OUT <- vector("list", length = lavdata@ngroups)
  if (is.null(out$group)) {
    out$group <- rep(1L, length(out$lhs))
  }
  # do we have a statistic?
  # determine column we need
  NAMES <- names(out)
  stat.idx <- which(NAMES %in% c(
    "cor", "cor.un",
    "G2", "G2.un",
    "X2", "X2.un",
    "RMSEA", "RMSEA.un",
    "G2.average", "G2.plarge", "G2.nlarge",
    "X2.average", "X2.plarge", "X2.nlarge"
  ))
  if (length(stat.idx) == 0) {
    statistic <- "obs.freq"
  } else if (length(stat.idx) > 1) {
    lav_msg_stop(gettext(
      "more than one statistic for table output:"),
      paste(NAMES[stat.idx], collapse = " ")
    )
  } else {
    statistic <- NAMES[stat.idx]
  }

  for (g in 1:lavdata@ngroups) {
    case.idx <- which(out$group == g)
    ID.group <- unique(out$id[out$group == g])
    TMP <- lapply(ID.group, function(x) {
      Tx <- out[out$id == x, ]
      M <- matrix(
        Tx[, statistic],
        max(Tx$row), max(Tx$col)
      )
      rownames(M) <- unique(Tx$row)
      colnames(M) <- unique(Tx$col)
      class(M) <- c("lavaan.matrix", "matrix")
      M
    })
    names(TMP) <- unique(paste(out$lhs[case.idx], out$rhs[case.idx],
      sep = "_"
    ))
    OUT[[g]] <- TMP
  }

  if (lavdata@ngroups == 1L && drop.list.single.group) {
    OUT <- OUT[[1]]
  } else {
    if (length(lavdata@group.label) > 0L) {
      names(OUT) <- unlist(lavdata@group.label)
    }
  }

  OUT
}



# The function lav_tables_univariate_freq_cell computes the univariate (one-way) frequency tables.
# The function closely folows the "logic" of the lavaan function
# lav_tables_pairwise_freq_cell.
# The output is either a list or a data.frame depending on the value the logical
# input argument as.data.frame. Either way, the same information is contained which is:
# a) the observed (univariate) frequencies f_ia, i=1,...,p (variables),
#    a=1,...,ci (response categories), with a index running faster than i index.
# b) an index vector with the name varb which indicates which variable each frequency refers to.
# c) an index vector with the name group which indicates which group each frequency
#    refers to when multi-group analysis.
# d) an index vector with the name level which indicates which level within
#    each ordinal variable each frequency refers to.
# e) a vector nobs which gives how many cases where considered to compute the
#    corresponding frequency. Since we use the available data for each variable
#    when missing=="available_cases" we expect these numbers to differ when
#    missing values are present.
# f) an index vector with the name id indexing each univariate table,
#    1 goes to first variable in the first group, 2 to 2nd variable in the second
#    group and so on. The last table has the index equal to (no of groups)*(no of variables).

lav_tables_univariate_freq_cell <- function(lavdata = NULL,
                                            as.data.frame. = TRUE) {
  # shortcuts
  vartable <- as.data.frame(lavdata@ov, stringsAsFactors = FALSE)
  X <- lavdata@X
  ov.names <- lavdata@ov.names
  ngroups <- lavdata@ngroups

  # identify 'categorical' variables
  cat.idx <- which(vartable$type %in% c("ordered", "factor"))

  # do we have any categorical variables?
  if (length(cat.idx) == 0L) {
    lav_msg_stop(gettext("no categorical variables are found"))
  }

  # univariate tables
  univariate.tables <- vartable$name[cat.idx]
  univariate.tables <- rbind(univariate.tables,
    seq_len(length(univariate.tables)),
    deparse.level = 0
  )
  ntables <- ncol(univariate.tables)

  # for each group, for each pairwise table, collect information
  UNI_TABLES <- vector("list", length = ngroups)
  for (g in 1:ngroups) {
    UNI_TABLES[[g]] <- apply(univariate.tables,
      MARGIN = 2,
      FUN = function(x) {
        idx1 <- which(vartable$name == x[1])
        id <- (g - 1) * ntables + as.numeric(x[2])
        ncell <- vartable$nlev[idx1]

        # compute one-way observed frequencies
        Y1 <- X[[g]][, idx1]
        UNI_FREQ <- tabulate(Y1, nbins = max(Y1, na.rm = TRUE))

        list(
          id = rep.int(id, ncell),
          varb = rep.int(x[1], ncell),
          group = rep.int(g, ncell),
          nobs = rep.int(sum(UNI_FREQ), ncell),
          level = seq_len(ncell),
          obs.freq = UNI_FREQ
        )
      }
    )
  }

  if (as.data.frame.) {
    for (g in 1:ngroups) {
      UNI_TABLE <- UNI_TABLES[[g]]
      UNI_TABLE <- lapply(UNI_TABLE, as.data.frame,
        stringsAsFactors = FALSE
      )
      if (g == 1) {
        out <- do.call(rbind, UNI_TABLE)
      } else {
        out <- rbind(out, do.call(rbind, UNI_TABLE))
      }
    }
    if (g == 1) {
      # remove group column
      out$group <- NULL
    }
  } else {
    if (ngroups == 1L) {
      out <- UNI_TABLES[[1]]
    } else {
      out <- UNI_TABLES
    }
  }

  out
}

# utility functions for pairwise maximum likelihood

# stub for lav_pml_fml_dploglik_dimplied
lav_pml_fml_dploglik_dimplied <- function(Sigma.hat = NULL, # model-based var/cov/cor
                       TH = NULL, # model-based thresholds + means
                       th.idx = NULL, # threshold idx per variable
                       num.idx = NULL, # which variables are numeric
                       X = NULL, # data
                       eXo = NULL, # external covariates
                       lavcache = NULL, # housekeeping stuff
                       scores = FALSE, # return case-wise scores
                       negative = TRUE) {
  lav_msg_stop(gettext("not implemented"))
}

# the first derivative of the pairwise logLik function with respect to the
# thresholds/slopes/var/correlations; together with DELTA, we can use the
# chain rule to get the gradient
# this is adapted from code written by Myrsini Katsikatsou
# first attempt - YR 5 okt 2012
# HJ 18/10/23: Modification for complex design and completely observed data (no
# missing) with only ordinal indicators to get the right gradient for the
# optimisation and Hessian computation.
lav_pml_dploglik_dimplied <- function(Sigma.hat = NULL, # model-based var/cov/cor
                       Mu.hat = NULL, # model-based means
                       TH = NULL, # model-based thresholds + means
                       th.idx = NULL, # threshold idx per variable
                       num.idx = NULL, # which variables are numeric
                       X = NULL, # data
                       eXo = NULL, # external covariates
                       wt = NULL, # case weights (not used yet)
                       lavcache = NULL, # housekeeping stuff
                       PI = NULL, # slopes
                       missing = "listwise", # how to deal with missings
                       scores = FALSE, # return case-wise scores
                       negative = TRUE) { # multiply by -1

  # diagonal of Sigma.hat is not necessarily 1, even for categorical vars
  Sigma.hat2 <- Sigma.hat
  if (length(num.idx) > 0L) {
    diag(Sigma.hat2)[-num.idx] <- 1
  } else {
    diag(Sigma.hat2) <- 1
  }
  Cor.hat <- cov2cor(Sigma.hat2) # to get correlations (rho!)
  cors <- lav_matrix_vech(Cor.hat, diagonal = FALSE)

  if (any(abs(cors) > 1)) {
    # what should we do now... force cov2cor?
    # cat("FFFFOOOORRRRRCEEE PD!\n")
    # Sigma.hat <- Matrix::nearPD(Sigma.hat)
    # Sigma.hat <- as.matrix(Sigma.hat$mat)
    # Sigma.hat <- cov2cor(Sigma.hat)
    # cors <- Sigma.hat[lower.tri(Sigma.hat)]
    idx <- which(abs(cors) > 0.99)
    cors[idx] <- 0.99 # clip
    # cat("CLIPPING!\n")
  }

  nvar <- nrow(Sigma.hat)
  pstar <- nvar * (nvar - 1) / 2
  ov.types <- rep("ordered", nvar)
  if (length(num.idx) > 0L) ov.types[num.idx] <- "numeric"
  if (!is.null(eXo)) {
    nexo <- ncol(eXo)
  } else {
    nexo <- 0
  }


  if (all(ov.types == "numeric")) {
    N.TH <- nvar
  } else {
    N.TH <- length(th.idx)
  }
  N.SL <- nvar * nexo
  N.VAR <- length(num.idx)
  N.COR <- pstar

  # add num.idx to th.idx
  if (length(num.idx) > 0L) {
    th.idx[th.idx == 0] <- num.idx
  }

  # print(Sigma.hat); print(TH); print(th.idx); print(num.idx); print(str(X))

  # shortcut for ordinal-only/no-exo case
  if (!scores && all(ov.types == "ordered") && nexo == 0L) {
    # >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    if (is.null(wt)) {
      n.xixj.vec <- lavcache$bifreq
    } else {
      n.xixj.vec <- lavcache$sum_obs_weights_xixj_ab_vec
    }
    gradient <- lav_pml_grad_tau_rho(
      no.x = nvar,
      all.thres = TH,
      index.var.of.thres = th.idx,
      rho.xixj = cors,
      n.xixj.vec = n.xixj.vec,
      out.lav_pml_longvec_ind = lavcache$long
    )

    # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    if (missing == "available.cases") {
      uniPI <- lav_pml_th_uni_prob(TH = TH, th.idx = th.idx)
      tmp <- lavcache$uniweights / uniPI

      var.idx <- split(th.idx, th.idx)
      var.idx <- unlist(lapply(var.idx, function(x) {
        c(x, x[1])
      }))

      tmp.varwise <- split(tmp, var.idx)
      tmp1 <- unlist(lapply(
        tmp.varwise,
        function(x) {
          c(x[-length(x)])
        }
      ))
      tmp2 <- unlist(lapply(tmp.varwise, function(x) {
        c(x[-1])
      }))

      uni.der.tau <- dnorm(TH) * (tmp1 - tmp2)
      nTH <- length(TH)
      gradient[1:nTH] <- gradient[1:nTH] + uni.der.tau
    }

    if (negative) {
      gradient <- -1 * gradient
    }
    return(gradient)
  }

  # in this order: TH/MEANS + SLOPES + VAR + COR
  GRAD.size <- N.TH + N.SL + N.VAR + N.COR

  # scores or gradient?
  if (scores) {
    SCORES <- matrix(0, nrow(X), GRAD.size) # we will sum up over all pairs
  } else {
    GRAD <- matrix(0, pstar, GRAD.size) # each pair is a row
  }
  PSTAR <- matrix(0, nvar, nvar) # utility matrix, to get indices
  PSTAR[lav_matrix_vech_idx(nvar, diagonal = FALSE)] <- 1:pstar
  N <- length(X[, 1])

  for (j in seq_len(nvar - 1L)) {
    for (i in (j + 1L):nvar) {
      # cat(" i = ", i, " j = ", j, "\n") # debug only
      pstar.idx <- PSTAR[i, j]
      cor.idx <- N.TH + N.SL + N.VAR + PSTAR[i, j]
      th.idx_i <- which(th.idx == i)
      th.idx_j <- which(th.idx == j)
      if (nexo > 0L) {
        sl.idx_i <- N.TH + seq(i, by = nvar, length.out = nexo)
        sl.idx_j <- N.TH + seq(j, by = nvar, length.out = nexo)

        if (length(num.idx) > 0L) {
          var.idx_i <- N.TH + N.SL + match(i, num.idx)
          var.idx_j <- N.TH + N.SL + match(j, num.idx)
        }
      } else {
        if (length(num.idx) > 0L) {
          var.idx_i <- N.TH + match(i, num.idx)
          var.idx_j <- N.TH + match(j, num.idx)
        }
      }
      if (ov.types[i] == "numeric" && ov.types[j] == "numeric") {
        if (nexo > 1L) {
          lav_msg_stop(gettext(
            "mixed + exo in PML not implemented;
            try optim.gradient = \"numerical\""))
        }

        SC <- lav_mvnorm_scores_mu_vech_sigma(
          Y = X[, c(i, j)],
          Mu = Mu.hat[c(i, j)], Sigma = Sigma.hat[c(i, j), c(i, j)]
        )

        if (scores) {
          if (all(ov.types == "numeric") && nexo == 0L) {
            # MU1 + MU2
            SCORES[, c(i, j)] <- SCORES[, c(i, j)] + SC[, c(1, 2)]
            # VAR1 + COV_12 + VAR2
            var.idx <- (nvar +
              lav_matrix_vech_match_idx(nvar, idx = c(i, j)))
            SCORES[, var.idx] <- SCORES[, var.idx] + SC[, c(3, 4, 5)]
          } else { # mixed ordered/continuous
            # MU
            mu.idx <- c(th.idx_i, th.idx_j)
            SCORES[, mu.idx] <- SCORES[, mu.idx] + (-1) * SC[, c(1, 2)]
            # VAR+COV
            var.idx <- c(var.idx_i, cor.idx, var.idx_j)
            SCORES[, var.idx] <- SCORES[, var.idx] + SC[, c(3, 4, 5)]
          }
        } else {
          if (all(ov.types == "numeric") && nexo == 0L) {
            mu.idx <- c(i, j)
            sigma.idx <- (nvar +
              lav_matrix_vech_match_idx(nvar, idx = c(i, j)))
            # MU1 + MU2
            GRAD[pstar.idx, mu.idx] <-
              colSums(SC[, c(1, 2)], na.rm = TRUE)
          } else {
            mu.idx <- c(th.idx_i, th.idx_j)
            sigma.idx <- c(var.idx_i, cor.idx, var.idx_j)
            # MU (reverse sign!)
            GRAD[pstar.idx, mu.idx] <-
              -1 * colSums(SC[, c(1, 2)], na.rm = TRUE)
          }
          # SIGMA
          GRAD[pstar.idx, sigma.idx] <-
            colSums(SC[, c(3, 4, 5)], na.rm = TRUE)
        } # gradient only
      } else if (ov.types[i] == "numeric" && ov.types[j] == "ordered") {
        # polyserial correlation
        if (nexo > 1L) {
          lav_msg_stop(gettext(
            "mixed + exo in PML not implemented;
            try optim.gradient = \"numerical\""))
        }

        SC.COR.UNI <- lav_bvmix_cor_scores(
          Y1 = X[, i], Y2 = X[, j],
          eXo = NULL, wt = wt,
          evar.y1 = Sigma.hat[i, i],
          beta.y1 = Mu.hat[i],
          th.y2 = TH[th.idx == j],
          sl.y2 = NULL,
          rho = Cor.hat[i, j],
          sigma.correction = TRUE
        )

        if (scores) {
          # MU
          SCORES[, th.idx_i] <- (SCORES[, th.idx_i] +
            -1 * SC.COR.UNI$dx.mu.y1)
          # TH
          SCORES[, th.idx_j] <- (SCORES[, th.idx_j] +
            SC.COR.UNI$dx.th.y2)
          # VAR
          SCORES[, var.idx_i] <- (SCORES[, var.idx_i] +
            SC.COR.UNI$dx.var.y1)
          # COR
          SCORES[, cor.idx] <- (SCORES[, cor.idx] +
            SC.COR.UNI$dx.rho)
        } else {
          # MU
          GRAD[pstar.idx, th.idx_i] <-
            -1 * sum(SC.COR.UNI$dx.mu.y1, na.rm = TRUE)
          # TH
          GRAD[pstar.idx, th.idx_j] <-
            colSums(SC.COR.UNI$dx.th.y2, na.rm = TRUE)
          # VAR
          GRAD[pstar.idx, var.idx_i] <-
            sum(SC.COR.UNI$dx.var.y1, na.rm = TRUE)
          # COR
          GRAD[pstar.idx, cor.idx] <-
            sum(SC.COR.UNI$dx.rho, na.rm = TRUE)
        } # grad only
      } else if (ov.types[j] == "numeric" && ov.types[i] == "ordered") {
        # polyserial correlation
        if (nexo > 1L) {
          lav_msg_stop(gettext(
            "mixed + exo in PML not implemented;
            try optim.gradient = \"numerical\""))
        }

        SC.COR.UNI <- lav_bvmix_cor_scores(
          Y1 = X[, j], Y2 = X[, i],
          eXo = NULL, wt = wt,
          evar.y1 = Sigma.hat[j, j],
          beta.y1 = Mu.hat[j],
          th.y2 = TH[th.idx == i],
          rho = Cor.hat[i, j],
          sigma.correction = TRUE
        )

        if (scores) {
          # MU
          SCORES[, th.idx_j] <- (SCORES[, th.idx_j] +
            -1 * SC.COR.UNI$dx.mu.y1)
          # TH
          SCORES[, th.idx_i] <- (SCORES[, th.idx_i] +
            SC.COR.UNI$dx.th.y2)
          # VAR
          SCORES[, var.idx_j] <- (SCORES[, var.idx_j] +
            SC.COR.UNI$dx.var.y1)
          # COR
          SCORES[, cor.idx] <- (SCORES[, cor.idx] +
            SC.COR.UNI$dx.rho)
        } else {
          # MU
          GRAD[pstar.idx, th.idx_j] <-
            -1 * sum(SC.COR.UNI$dx.mu.y1, na.rm = TRUE)
          # TH
          GRAD[pstar.idx, th.idx_i] <-
            colSums(SC.COR.UNI$dx.th.y2, na.rm = TRUE)
          # VAR
          GRAD[pstar.idx, var.idx_j] <-
            sum(SC.COR.UNI$dx.var.y1, na.rm = TRUE)
          # COR
          GRAD[pstar.idx, cor.idx] <-
            sum(SC.COR.UNI$dx.rho, na.rm = TRUE)
        } # grad only
      } else if (ov.types[i] == "ordered" && ov.types[j] == "ordered") {
        # polychoric correlation
        if (nexo == 0L) {
          SC.COR.UNI <-
            lav_bvord_cor_scores(
              Y1 = X[, i], Y2 = X[, j],
              eXo = NULL, wt = wt,
              rho = Sigma.hat[i, j],
              fit.y1 = NULL, # fixme
              fit.y2 = NULL, # fixme
              th.y1 = TH[th.idx == i],
              th.y2 = TH[th.idx == j],
              sl.y1 = NULL,
              sl.y2 = NULL,
              na.zero = TRUE
            )
        } else {
          SC.COR.UNI <-
            lav_pml_dbilogl_dpar_x(
              Y1 = X[, i],
              Y2 = X[, j],
              eXo = eXo,
              Rho = Sigma.hat[i, j],
              th.y1 = TH[th.idx == i],
              th.y2 = TH[th.idx == j],
              sl.y1 = PI[i, ],
              sl.y2 = PI[j, ],
              missing.ind = missing
            )
        }

        if (scores) {
          # TH
          SCORES[, th.idx_i] <- SCORES[, th.idx_i] + SC.COR.UNI$dx.th.y1
          SCORES[, th.idx_j] <- SCORES[, th.idx_j] + SC.COR.UNI$dx.th.y2

          # SL
          if (nexo > 0L) {
            SCORES[, sl.idx_i] <- SCORES[, sl.idx_i] + SC.COR.UNI$dx.sl.y1
            SCORES[, sl.idx_j] <- SCORES[, sl.idx_j] + SC.COR.UNI$dx.sl.y2
          }
          # NO VAR
          # RHO
          SCORES[, cor.idx] <- SCORES[, cor.idx] + SC.COR.UNI$dx.rho
        } else {
          # TH
          if (length(th.idx_i) > 1L) {
            GRAD[pstar.idx, th.idx_i] <-
              colSums(SC.COR.UNI$dx.th.y1, na.rm = TRUE)
          } else {
            GRAD[pstar.idx, th.idx_i] <-
              sum(SC.COR.UNI$dx.th.y1, na.rm = TRUE)
          }
          if (length(th.idx_j) > 1L) {
            GRAD[pstar.idx, th.idx_j] <-
              colSums(SC.COR.UNI$dx.th.y2, na.rm = TRUE)
          } else {
            GRAD[pstar.idx, th.idx_j] <-
              sum(SC.COR.UNI$dx.th.y2, na.rm = TRUE)
          }

          # SL
          if (nexo > 0L) {
            if (length(sl.idx_i) > 1L) {
              GRAD[pstar.idx, sl.idx_i] <-
                colSums(SC.COR.UNI$dx.sl.y1, na.rm = TRUE)
            } else {
              GRAD[pstar.idx, sl.idx_i] <-
                sum(SC.COR.UNI$dx.sl.y1, na.rm = TRUE)
            }
            if (length(sl.idx_j) > 1L) {
              GRAD[pstar.idx, sl.idx_j] <-
                colSums(SC.COR.UNI$dx.sl.y2, na.rm = TRUE)
            } else {
              GRAD[pstar.idx, sl.idx_j] <-
                sum(SC.COR.UNI$dx.sl.y2, na.rm = TRUE)
            }
          }
          # NO VAR

          # RHO
          GRAD[pstar.idx, cor.idx] <-
            sum(SC.COR.UNI$dx.rho, na.rm = TRUE)
        }

        # GRAD2 <- numDeriv::grad(func = pc_logl_x,
        #                        x = c(Sigma.hat[i,j],
        #                              TH[ th.idx == i ],
        #                              TH[ th.idx == j]),
        #                        Y1  = X[,i],
        #                        Y2  = X[,j],
        #                        eXo = eXo,
        #                        nth.y1 = sum( th.idx == i ),
        #                        nth.y2 = sum( th.idx == j ))
      }
    }
  }

  if (missing == "available.cases" && all(ov.types == "ordered")) {
    if (nexo == 0L) {
      UNI_SCORES <- matrix(0, nrow(X), N.TH)
      for (i in seq_len(nvar)) {
        th.idx_i <- which(th.idx == i)
        derY1 <- lav_pml_uni_scores(
          Y1 = X[, i], th.y1 = TH[th.idx == i],
          eXo = NULL, sl.y1 = NULL,
          weights.casewise = lavcache$uniweights.casewise
        )
        UNI_SCORES[, th.idx_i] <- derY1$dx.th.y1
      }
    } else {
      UNI_SCORES <- matrix(0, nrow(X), ncol = (N.TH + N.SL))
      for (i in seq_len(nvar)) {
        th.idx_i <- which(th.idx == i)
        sl.idx_i <- N.TH + seq(i, by = nvar, length.out = nexo)
        derY1 <- lav_pml_uni_scores(
          Y1 = X[, i], th.y1 = TH[th.idx == i],
          eXo = eXo, sl.y1 = PI[i, ],
          weights.casewise = lavcache$uniweights.casewise
        )
        UNI_SCORES[, th.idx_i] <- derY1$dx.th.y1
        UNI_SCORES[, sl.idx_i] <- derY1$dx.sl.y1
      }
      if (scores) {
        SCORES <- SCORES[, 1:(N.TH + N.SL)] + UNI_SCORES
      } else {
        uni_gradient <- colSums(UNI_SCORES)
      }
    }
  }

  # do we need scores?
  if (scores) {
    return(SCORES)
  }

  # DEBUG
  # :print(GRAD)
  ###########



  # gradient is sum over all pairs
  gradient <- colSums(GRAD, na.rm = TRUE)

  if (missing == "available.cases" && all(ov.types == "ordered")) {
    if (nexo == 0L) {
      gradient[1:N.TH] <- gradient + uni_gradient
    } else {
      gradient[1:(N.TH + N.SL)] <- gradient + uni_gradient
    }
  }

  # we multiply by -1 because we minimize
  if (negative) {
    gradient <- -1 * gradient
  }

  gradient
}


### all code below written by Myrsini Katsikatsou


# The function lav_pml_grad_tau_rho
# input:
# no.x -  is scalar, the number of ordinal variables
# all.thres  - is vector containing the thresholds of all variables in the
#              following order: thres_var1, thres_var2,..., thres_var_p
#              within each variable the thresholds are in ascending order
#              Note that all.thres do NOT contain tau_0=-Inf and tau_last=Inf
#              for all variables.
# index.var.of.thres - a vector keeping track to which variable the thresholds
#                      in all.thres belongs to, it is of the form
#                      (1,1,1..., 2,2,2,...,  p,p,p,...)
# rho.xixj - is the vector of all correlations where j runs faster than i
#            i.e. the order is rho_12, rho_13, ..., rho_1p, rho_23, ..., rho_2p,
#            etc.
# n.xixj.vec -  a vector with the observed frequency for every combination
#               of categories and every pair. The frequencies are given in
#               the same order as the expected probabilities in the output of
#               lav_pml_expprob_vec output
# out.lav_pml_longvec_ind - it is the output of function lav_pml_longvec_ind
# the output: it gives the elements of der.L.to.tau and der.L.to.rho in this
#             order. The elements of der.L.to.tau where the elements are
#             ordered as follows: the thresholds of each variable with respect
#             to ascending order of the variable index (i.e. thres_var1,
#             thres_var2, etc.) and within each variable the thresholds in
#             ascending order.
#             The elements of vector der.L.to.rho are der.Lxixj.to.rho.xixj
#             where j runs faster than i.

# The function depends on four other functions: lav_pml_longvec_th_rho,
# lav_pml_expprob_vec, lav_pml_dl_drho, and lav_pml_dl_dtau, all given below.

# if n.xixj.ab is either an array or a list the following should be done
# n.xixj.vec <- if(is.array(n.xixj.ab)) {
#                 c(n.xixj.ab)
#              } else if(is.list(n.xixj.ab)){
#                 unlist(n.xixj.ab)
#              }


lav_pml_grad_tau_rho <- function(no.x, all.thres, index.var.of.thres, rho.xixj,
                         n.xixj.vec, out.lav_pml_longvec_ind) {
  out.lav_pml_longvec_th_rho <- lav_pml_longvec_th_rho(
    no.x = no.x, all.thres = all.thres,
    index.var.of.thres = index.var.of.thres,
    rho.xixj = rho.xixj
  )
  pi.xixj <- lav_pml_expprob_vec(
    ind.vec = out.lav_pml_longvec_ind,
    th.rho.vec = out.lav_pml_longvec_th_rho
  )

  out.lav_pml_dl_drho <- lav_pml_dl_drho(
    ind.vec = out.lav_pml_longvec_ind,
    th.rho.vec = out.lav_pml_longvec_th_rho,
    n.xixj = n.xixj.vec, pi.xixj = pi.xixj, no.x = no.x
  )

  out.lav_pml_dl_dtau <- lav_pml_dl_dtau(
    ind.vec = out.lav_pml_longvec_ind,
    th.rho.vec = out.lav_pml_longvec_th_rho,
    n.xixj = n.xixj.vec, pi.xixj = pi.xixj,
    no.x = no.x
  )

  grad <- c(out.lav_pml_dl_dtau, out.lav_pml_dl_drho)
  attr(grad, "pi.xixj") <- pi.xixj

  grad
}
################################################################################




# The input of the function  lav_pml_longvec_ind:

# no.x is scalar, the number of ordinal variables

# all.thres is vector containing the thresholds of all variables in the
# following order: thres_var1, thres_var2,..., thres_var_p
# within each variable the thresholds are in ascending order
# Note that all.thres does NOT contain the first and the last threshold of the
# variables, i.e. tau_0=-Inf and tau_last=Inf

# index.var.of.thres is a vector keeping track to which variable the thresholds
# in all.thres belongs to, it is of the form (1,1,1..., 2,2,2,...,  p,p,p,...)

# The output of the function:
# it is a list of vectors keeping track of the indices
# of thresholds, of variables, and of pairs, and two T/F vectors indicating
# if the threshold index corresponds to the last threshold of a variable; all
# these for all pairs of variables. All are needed for the
# computation of expected probabilities, der.L.to.rho, and der.L.to.tau

# all duplications of indices are done as follows: within each pair of variables,
# xi-xj, if for example we want to duplicate the indices of the thresholds,
# tau^xi_a and tau^xj_b, then index a runs faster than b, i.e. for each b we
# take all different tau^xi's, and then we proceed to the next b and do the
# same. In other words if it was tabulated we fill the table columnwise.

# All pairs xi-xj are taken with index j running faster than i.

# Note that each variable may have a different number of categories, that's why
# for example we take lists below.

lav_pml_longvec_ind <- function(no.x, all.thres, index.var.of.thres) {
  no.thres.of.each.var <- tapply(all.thres, index.var.of.thres, length)
  index.pairs <- utils::combn(no.x, 2)
  no.pairs <- ncol(index.pairs)

  # index.thres.var1.of.pair and index.thres.var2.of.pair contain the indices of
  # of all thresholds (from tau_0 which is -Inf to tau_last which is Inf)
  # for any pair of variables appropriately duplicated so that the two vectors
  # together give all possible combinations of thresholds indices
  # Since here the threshold indices 0 and "last" are included, the vectors are
  # longer than the vectors thres.var1.of.pair and thres.var2.of.pair above.
  index.thres.var1.of.pair <- vector("list", no.pairs)
  index.thres.var2.of.pair <- vector("list", no.pairs)

  # index.var1.of.pair and index.var2.of.pair keep track the index of the
  # variable that the thresholds in index.thres.var1.of.pair and
  # index.thres.var2.of.pair belong to, respectively. So, these two variables
  # are of same length as that of index.thres.var1.of.pair and
  # index.thres.var2.of.pair
  index.var1.of.pair <- vector("list", no.pairs)
  index.var2.of.pair <- vector("list", no.pairs)

  # index.pairs.extended gives the index of the pair for each pair of variables
  # e.g. pair of variables 1-2 has index 1, variables 1-3 has index 2, etc.
  # The vector is of the same length as index.thres.var1.of.pair,
  # index.thres.var2.of.pair, index.var1.of.pair, and index.var2.of.pair
  index.pairs.extended <- vector("list", no.pairs)

  for (i in 1:no.pairs) {
    no.thres.var1.of.pair <- no.thres.of.each.var[index.pairs[1, i]]
    no.thres.var2.of.pair <- no.thres.of.each.var[index.pairs[2, i]]

    index.thres.var1.of.pair[[i]] <- rep(0:(no.thres.var1.of.pair + 1),
      times = (no.thres.var2.of.pair + 2)
    )
    index.thres.var2.of.pair[[i]] <- rep(0:(no.thres.var2.of.pair + 1),
      each = (no.thres.var1.of.pair + 2)
    )
    length.vec <- length(index.thres.var1.of.pair[[i]])
    index.var1.of.pair[[i]] <- rep(index.pairs[1, i], length.vec)
    index.var2.of.pair[[i]] <- rep(index.pairs[2, i], length.vec)
    index.pairs.extended[[i]] <- rep(i, length.vec)
  }

  index.thres.var1.of.pair <- unlist(index.thres.var1.of.pair)
  index.thres.var2.of.pair <- unlist(index.thres.var2.of.pair)
  index.var1.of.pair <- unlist(index.var1.of.pair)
  index.var2.of.pair <- unlist(index.var2.of.pair)
  index.pairs.extended <- unlist(index.pairs.extended)

  # indicator vector (T/F) showing which elements of index.thres.var1.of.pair
  # correspond to the last thresholds of variables. The length is the same as
  # that of index.thres.var1.of.pair.
  last.thres.var1.of.pair <- index.var1.of.pair == 1 &
    index.thres.var1.of.pair == (no.thres.of.each.var[1] + 1)
  # we consider up to variable (no.x-1) because in pairs xi-xj where j runs
  # faster than i, the last variable is not included in the column of xi's
  for (i in 2:(no.x - 1)) {
    new.condition <- index.var1.of.pair == i &
      index.thres.var1.of.pair == (no.thres.of.each.var[i] + 1)
    last.thres.var1.of.pair <- last.thres.var1.of.pair | new.condition
  }

  # indicator vector (T/F) showing which elements of index.thres.var2.of.pair
  # correspond to the last thresholds of variables. Notet that in pairs xi-xj
  # where j runs faster than i, the first variable is not included in the column
  # of xj's. That's why we start with variable 2. The length is the same as
  # that of index.thres.var1.of.pair.
  last.thres.var2.of.pair <- index.var2.of.pair == 2 &
    index.thres.var2.of.pair == (no.thres.of.each.var[2] + 1)
  for (i in 3:no.x) {
    new.condition <- index.var2.of.pair == i &
      index.thres.var2.of.pair == (no.thres.of.each.var[i] + 1)
    last.thres.var2.of.pair <- last.thres.var2.of.pair | new.condition
  }

  list(
    index.thres.var1.of.pair = index.thres.var1.of.pair,
    index.thres.var2.of.pair = index.thres.var2.of.pair,
    index.var1.of.pair = index.var1.of.pair,
    index.var2.of.pair = index.var2.of.pair,
    index.pairs.extended = index.pairs.extended,
    last.thres.var1.of.pair = last.thres.var1.of.pair,
    last.thres.var2.of.pair = last.thres.var2.of.pair
  )
}
################################################################################


# The input of the function  lav_pml_longvec_th_rho:

# no.x is scalar, the number of ordinal variables

# all.thres is vector containing the thresholds of all variables in the
# following order: thres_var1, thres_var2,..., thres_var_p
# within each variable the thresholds are in ascending order
# Note that all.thres does NOT contain the first and the last threshold of the
# variables, i.e. tau_0=-Inf and tau_last=Inf

# index.var.of.thres is a vector keeping track to which variable the thresholds
# in all.thres belongs to, it is of the form (1,1,1..., 2,2,2,...,  p,p,p,...)

# rho.xixj is the vector of all corrlations where j runs faster than i
# i.e. the order is rho_12, rho_13, ..., rho_1p, rho_23, ..., rho_2p, etc.

# The output of the function:
# it is a list of vectors with thresholds and rho's duplicated appropriately,
# all needed for the computation of expected probabilities,
# der.L.to.rho, and der.L.to.tau

# all duplications below are done as follows: within each pair of variables,
# xi-xj, if for example we want to duplicate their thresholds, tau^xi_a and
# tau^xj_b, then index a runs faster than b, i.e. for each b we take all
# different tau^xi's, and then we proceed to the next b and do the same.
# In other words if it was tabulated we fill the table columnwise.

# All pairs xi-xj are taken with index j running faster than i.

# Note that each variable may have a different number of categories, that's why
# for example we take lists below.

lav_pml_longvec_th_rho <- function(no.x, all.thres, index.var.of.thres, rho.xixj) {
  no.thres.of.each.var <- tapply(all.thres, index.var.of.thres, length)
  index.pairs <- utils::combn(no.x, 2)
  no.pairs <- ncol(index.pairs)

  # create the long vectors needed for the computation of expected probabilities
  # for each cell and each pair of variables. The vectors thres.var1.of.pair and
  # thres.var2.of.pair together give all the possible combinations of the
  # thresholds of any two variables. Note the combinations (-Inf, -Inf),
  # (-Inf, Inf), (Inf, -Inf), (Inf, Inf) are NOT included. Only the combinations
  # of the middle thresholds (tau_1 to tau_(last-1)).
  # thres.var1.of.pair and thres.var2.of.pair give the first and the second
  # argument, respectively, in functions pbivnorm and lav_dbinorm
  thres.var1.of.pair <- vector("list", no.pairs)
  thres.var2.of.pair <- vector("list", no.pairs)

  # Extending the rho.vector accordingly so that it will be the the third
  # argument in pbivnorm and lav_dbinorm functions. It is of same length as
  # thres.var1.of.pair and thres.var2.of.pair.
  rho.vector <- vector("list", no.pairs)

  # thres.var1.for.dnorm.in.der.pi.to.tau.xi and
  # thres.var2.for.dnorm.in.der.pi.to.tau.xj give the thresholds of almost
  # all variables appropriately duplicated so that the vectors can be used
  # as input in dnorm() to compute der.pi.xixj.to.tau.xi and
  # der.pi.xixj.to.tau.xj.
  # thres.var1.for.dnorm.in.der.pi.to.tau.xi does not contain the thresholds of
  # the last variable and thres.var2.for.dnorm.in.der.pi.to.tau.xj those of
  # the first variable
  thres.var1.for.dnorm.in.der.pi.to.tau.xi <- vector("list", no.pairs)
  thres.var2.for.dnorm.in.der.pi.to.tau.xj <- vector("list", no.pairs)

  for (i in 1:no.pairs) {
    single.thres.var1.of.pair <- all.thres[index.var.of.thres == index.pairs[1, i]]
    single.thres.var2.of.pair <- all.thres[index.var.of.thres == index.pairs[2, i]]
    # remember that the first (-Inf) and last (Inf) thresholds are not included
    # so no.thres.var1.of.pair is equal to number of categories of var1 minus 1
    # similarly for no.thres.var2.of.pair
    no.thres.var1.of.pair <- no.thres.of.each.var[index.pairs[1, i]]
    no.thres.var2.of.pair <- no.thres.of.each.var[index.pairs[2, i]]

    thres.var1.of.pair[[i]] <- rep(single.thres.var1.of.pair,
      times = no.thres.var2.of.pair
    )
    thres.var2.of.pair[[i]] <- rep(single.thres.var2.of.pair,
      each = no.thres.var1.of.pair
    )
    rho.vector[[i]] <- rep(rho.xixj[i], length(thres.var1.of.pair[[i]]))

    thres.var1.for.dnorm.in.der.pi.to.tau.xi[[i]] <-
      rep(single.thres.var1.of.pair, times = (no.thres.var2.of.pair + 1))
    thres.var2.for.dnorm.in.der.pi.to.tau.xj[[i]] <-
      rep(single.thres.var2.of.pair, each = (no.thres.var1.of.pair + 1))
  }

  thres.var1.of.pair <- unlist(thres.var1.of.pair)
  thres.var2.of.pair <- unlist(thres.var2.of.pair)
  rho.vector <- unlist(rho.vector)
  thres.var1.for.dnorm.in.der.pi.to.tau.xi <-
    unlist(thres.var1.for.dnorm.in.der.pi.to.tau.xi)
  thres.var2.for.dnorm.in.der.pi.to.tau.xj <-
    unlist(thres.var2.for.dnorm.in.der.pi.to.tau.xj)

  # thres.var2.for.last.cat.var1 and thres.var1.for.last.cat.var2 are needed
  # for the computation of expected probabilities. In the computation of
  # \Phi_2(tau1, tau2; rho) when either tau1 or tau2 are Inf then it is enought
  # to compute pnorm() with the non-infinite tau as an argument
  # In particular when the first variable of the pair has tau_last= Inf
  # and the second a non-infite threshold we compute
  # pnorm(thres.var2.for.last.cat.var1). Similarly, when the second variable of
  # the pair has tau_last=Inf and the first a non-infite threshold we compute
  # pnorm(thres.var1.for.last.cat.var2).
  thres.var2.for.last.cat.var1 <- vector("list", (no.x - 1))
  thres.var1.for.last.cat.var2 <- vector("list", (no.x - 1))
  for (i in 1:(no.x - 1)) {
    thres.var2.for.last.cat.var1[[i]] <-
      c(all.thres[index.var.of.thres %in% (i + 1):no.x])
    thres.var1.for.last.cat.var2[[i]] <- rep(all.thres[index.var.of.thres == i],
      times = (no.x - i)
    )
  }
  thres.var2.for.last.cat.var1 <- unlist(thres.var2.for.last.cat.var1)
  thres.var1.for.last.cat.var2 <- unlist(thres.var1.for.last.cat.var2)


  list(
    thres.var1.of.pair = thres.var1.of.pair, # these 3 of same length
    thres.var2.of.pair = thres.var2.of.pair,
    rho.vector = rho.vector,

    # the following of length dependning on the number of categories
    thres.var1.for.dnorm.in.der.pi.to.tau.xi =
      thres.var1.for.dnorm.in.der.pi.to.tau.xi,
    thres.var2.for.dnorm.in.der.pi.to.tau.xj =
      thres.var2.for.dnorm.in.der.pi.to.tau.xj,
    thres.var2.for.last.cat.var1 = thres.var2.for.last.cat.var1,
    thres.var1.for.last.cat.var2 = thres.var1.for.last.cat.var2
  )
}
#########################################################



#########################################################

# The function  lav_pml_expprob_vec
# input: ind.vec - the output of function lav_pml_longvec_ind
#        th.rho.vec - the output of function lav_pml_longvec_th_rho
# output: it gives the elements of pairwiseTablesExpected()$pi.tables
# table-wise and column-wise within each table. In other words if
# pi^xixj_ab is the expected probability for the pair of variables xi-xj
# and categories a and b, then index a runs the fastest of all, followed by b,
# then by j, and lastly by i.

lav_pml_expprob_vec <- function(ind.vec, th.rho.vec) {
  prob.vec <- rep(NA, length(ind.vec$index.thres.var1.of.pair))

  prob.vec[ind.vec$index.thres.var1.of.pair == 0 |
    ind.vec$index.thres.var2.of.pair == 0] <- 0

  prob.vec[ind.vec$last.thres.var1.of.pair &
    ind.vec$last.thres.var2.of.pair] <- 1

  prob.vec[ind.vec$last.thres.var1.of.pair &
    ind.vec$index.thres.var2.of.pair != 0 &
    !ind.vec$last.thres.var2.of.pair] <-
    pnorm(th.rho.vec$thres.var2.for.last.cat.var1)

  prob.vec[ind.vec$last.thres.var2.of.pair &
    ind.vec$index.thres.var1.of.pair != 0 &
    !ind.vec$last.thres.var1.of.pair] <-
    pnorm(th.rho.vec$thres.var1.for.last.cat.var2)

  prob.vec[is.na(prob.vec)] <- pbivnorm(
    th.rho.vec$thres.var1.of.pair,
    th.rho.vec$thres.var2.of.pair,
    th.rho.vec$rho.vector
  )

  cum.term1 <- prob.vec[ind.vec$index.thres.var1.of.pair != 0 &
    ind.vec$index.thres.var2.of.pair != 0]

  cum.term2 <- prob.vec[ind.vec$index.thres.var1.of.pair != 0 &
    !ind.vec$last.thres.var2.of.pair]

  cum.term3 <- prob.vec[ind.vec$index.thres.var2.of.pair != 0 &
    !ind.vec$last.thres.var1.of.pair]

  cum.term4 <- prob.vec[!ind.vec$last.thres.var1.of.pair &
    !ind.vec$last.thres.var2.of.pair]

  PI <- cum.term1 - cum.term2 - cum.term3 + cum.term4

  # added by YR 11 nov 2012 to avoid Nan/-Inf
  # log(.Machine$double.eps) = -36.04365
  # all elements should be strictly positive
  PI[PI < .Machine$double.eps] <- .Machine$double.eps

  PI
}


# lav_pml_dl_drho
# input: ind.vec - the output of function lav_pml_longvec_ind
#        th.rho.vec - the output of function lav_pml_longvec_th_rho
#        n.xixj - a vector with the observed frequency for every combination
#                 of categories and every pair. The frequencies are given in
#                 the same order as the expected probabilities in the output of
#                 lav_pml_expprob_vec output
#        pi.xixj - the output of lav_pml_expprob_vec function
#        no.x    - the number of ordinal variables
# output: the vector of der.L.to.rho, each element corresponds to
#         der.Lxixj.to.rho.xixj where j runs faster than i

lav_pml_dl_drho <- function(ind.vec, th.rho.vec, n.xixj, pi.xixj, no.x) {
  prob.vec <- rep(NA, length(ind.vec$index.thres.var1.of.pair))

  prob.vec[ind.vec$index.thres.var1.of.pair == 0 |
    ind.vec$index.thres.var2.of.pair == 0 |
    ind.vec$last.thres.var1.of.pair |
    ind.vec$last.thres.var2.of.pair] <- 0

  prob.vec[is.na(prob.vec)] <- lav_dbinorm(th.rho.vec$thres.var1.of.pair,
    th.rho.vec$thres.var2.of.pair,
    rho = th.rho.vec$rho.vector
  )

  den.term1 <- prob.vec[ind.vec$index.thres.var1.of.pair != 0 &
    ind.vec$index.thres.var2.of.pair != 0]

  den.term2 <- prob.vec[ind.vec$index.thres.var1.of.pair != 0 &
    !ind.vec$last.thres.var2.of.pair]

  den.term3 <- prob.vec[ind.vec$index.thres.var2.of.pair != 0 &
    !ind.vec$last.thres.var1.of.pair]

  den.term4 <- prob.vec[!ind.vec$last.thres.var1.of.pair &
    !ind.vec$last.thres.var2.of.pair]

  der.pi.xixj.to.rho.xixj <- den.term1 - den.term2 - den.term3 + den.term4
  prod.terms <- (n.xixj / pi.xixj) * der.pi.xixj.to.rho.xixj

  # to get der.Lxixj.to.rho.xixj we should all the elements of
  # der.pi.xixj.to.rho.xixj which correspond to the pair xi-xj, to do so:
  xnew <- lapply(
    ind.vec[c("index.pairs.extended")],
    function(y) {
      y[ind.vec$index.thres.var1.of.pair != 0 &
        ind.vec$index.thres.var2.of.pair != 0]
    }
  )
  # der.L.to.rho is:
  tapply(prod.terms, xnew$index.pairs.extended, sum)
}
###########################################################################


# lav_pml_dl_dtau
# input: ind.vec - the output of function lav_pml_longvec_ind
#        th.rho.vec - the output of function lav_pml_longvec_th_rho
#        n.xixj - a vector with the observed frequency for every combination
#                 of categories and every pair. The frequencies are given in
#                 the same order as the expected probabilities in the output of
#                 lav_pml_expprob_vec output
#        pi.xixj - the output of lav_pml_expprob_vec function
# output: the vector of der.L.to.tau where the elements are ordered as follows:
#         the thresholds of each variable with respect to ascending order of
#         the variable index (i.e. thres_var1, thres_var2, etc.) and within
#         each variable the thresholds in ascending order.


lav_pml_dl_dtau <- function(ind.vec, th.rho.vec, n.xixj, pi.xixj, no.x = 0L) {
  # to compute der.pi.xixj.to.tau.xi
  xi <- lapply(
    ind.vec[c(
      "index.thres.var2.of.pair",
      "last.thres.var2.of.pair"
    )],
    function(y) {
      y[!(ind.vec$index.thres.var1.of.pair == 0 |
        ind.vec$last.thres.var1.of.pair)]
    }
  )

  cum.prob.vec <- rep(NA, length(xi$index.thres.var2.of.pair))
  cum.prob.vec[xi$index.thres.var2.of.pair == 0] <- 0
  cum.prob.vec[xi$last.thres.var2.of.pair] <- 1
  denom <- sqrt(1 - (th.rho.vec$rho.vector * th.rho.vec$rho.vector))
  cum.prob.vec[is.na(cum.prob.vec)] <-
    pnorm((th.rho.vec$thres.var2.of.pair -
      th.rho.vec$rho.vector * th.rho.vec$thres.var1.of.pair) /
      denom)
  den.prob.vec <- dnorm(th.rho.vec$thres.var1.for.dnorm.in.der.pi.to.tau.xi)
  der.pi.xixj.to.tau.xi <- den.prob.vec *
    (cum.prob.vec[xi$index.thres.var2.of.pair != 0] -
      cum.prob.vec[!xi$last.thres.var2.of.pair])

  # to compute der.pi.xixj.to.tau.xj
  xj <- lapply(
    ind.vec[c(
      "index.thres.var1.of.pair",
      "last.thres.var1.of.pair"
    )],
    function(y) {
      y[!(ind.vec$index.thres.var2.of.pair == 0 |
        ind.vec$last.thres.var2.of.pair)]
    }
  )

  cum.prob.vec <- rep(NA, length(xj$index.thres.var1.of.pair))
  cum.prob.vec[xj$index.thres.var1.of.pair == 0] <- 0
  cum.prob.vec[xj$last.thres.var1.of.pair] <- 1
  denom <- sqrt(1 - (th.rho.vec$rho.vector * th.rho.vec$rho.vector))
  cum.prob.vec[is.na(cum.prob.vec)] <-
    pnorm((th.rho.vec$thres.var1.of.pair -
      th.rho.vec$rho.vector * th.rho.vec$thres.var2.of.pair) /
      denom)
  den.prob.vec <- dnorm(th.rho.vec$thres.var2.for.dnorm.in.der.pi.to.tau.xj)
  der.pi.xixj.to.tau.xj <- den.prob.vec *
    (cum.prob.vec[xj$index.thres.var1.of.pair != 0] -
      cum.prob.vec[!xj$last.thres.var1.of.pair])

  # to compute der.Lxixj.tau.xi and der.Lxixj.tau.xi
  n.over.pi <- n.xixj / pi.xixj
  # get the appropriate differences of n.over.pi for der.Lxixj.to.tau.xi  and
  # der.Lxixj.to.tau.xj
  x3a <- lapply(ind.vec, function(y) {
    y[!(ind.vec$index.thres.var1.of.pair == 0 |
      ind.vec$index.thres.var2.of.pair == 0)]
  })
  diff.n.over.pi.to.xi <- n.over.pi[!x3a$last.thres.var1.of.pair] -
    n.over.pi[x3a$index.thres.var1.of.pair != 1]
  diff.n.over.pi.to.xj <- n.over.pi[!x3a$last.thres.var2.of.pair] -
    n.over.pi[x3a$index.thres.var2.of.pair != 1]
  # terms.der.Lxixj.to.tau.xi  and terms.der.Lxixj.to.tau.xj
  terms.der.Lxixj.to.tau.xi <- diff.n.over.pi.to.xi * der.pi.xixj.to.tau.xi
  terms.der.Lxixj.to.tau.xj <- diff.n.over.pi.to.xj * der.pi.xixj.to.tau.xj
  # to add appropriately elements of terms.der.Lxixj.to.tau.xi
  x3b <- lapply(
    ind.vec[c(
      "index.pairs.extended",
      "index.thres.var1.of.pair"
    )],
    function(y) {
      y[!(ind.vec$index.thres.var1.of.pair == 0 |
        ind.vec$last.thres.var1.of.pair |
        ind.vec$index.thres.var2.of.pair == 0)]
    }
  )
  # to add appropriately elements of terms.der.Lxixj.to.tau.xj
  x4b <- lapply(
    ind.vec[c(
      "index.pairs.extended",
      "index.thres.var2.of.pair"
    )],
    function(y) {
      y[!(ind.vec$index.thres.var2.of.pair == 0 |
        ind.vec$last.thres.var2.of.pair |
        ind.vec$index.thres.var1.of.pair == 0)]
    }
  )
  ind.pairs <- utils::combn(no.x, 2)
  # der.Lxixj.to.tau.xi is a matrix, nrow=no.pairs, ncol=max(no.of.free.thres)
  # thus, there are NA's, similarly for der.Lxixj.to.tau.xj
  der.Lxixj.to.tau.xi <- tapply(
    terms.der.Lxixj.to.tau.xi,
    list(
      x3b$index.pairs.extended,
      x3b$index.thres.var1.of.pair
    ),
    sum
  )
  der.Lxixj.to.tau.xj <- tapply(
    terms.der.Lxixj.to.tau.xj,
    list(
      x4b$index.pairs.extended,
      x4b$index.thres.var2.of.pair
    ),
    sum
  )

  # to add appropriately the terms of der.Lxixj.to.tau.xi and
  # der.Lxixj.to.tau.xj
  split.der.Lxixj.to.tau.xi <- split(
    as.data.frame(der.Lxixj.to.tau.xi),
    ind.pairs[1, ]
  )
  sums.der.Lxixj.to.tau.xi <- lapply(
    split.der.Lxixj.to.tau.xi,
    function(x) {
      y <- apply(x, 2, sum)
      y[!is.na(y)]
    }
  )
  # Note: NA exist in the case where the ordinal variables have different
  # number of response categories
  split.der.Lxixj.to.tau.xj <- split(
    as.data.frame(der.Lxixj.to.tau.xj),
    ind.pairs[2, ]
  )
  sums.der.Lxixj.to.tau.xj <- lapply(
    split.der.Lxixj.to.tau.xj,
    function(x) {
      y <- apply(x, 2, sum)
      y[!is.na(y)]
    }
  )
  # to get der.L.to.tau
  c(
    sums.der.Lxixj.to.tau.xi[[1]],
    c(unlist(sums.der.Lxixj.to.tau.xi[2:(no.x - 1)]) +
      unlist(sums.der.Lxixj.to.tau.xj[1:(no.x - 2)])),
    sums.der.Lxixj.to.tau.xj[[no.x - 1]]
  )
}

# - 0.6-13: fix multiple-group UG^2 bug (reported by Gronneberg, Foldnes and
#           Moss) when Satterthwaite = TRUE, ngroups > 1, and eq constraints.
#           Use ug2.old.approach = TRUE to get the old result

lav_test_satorra_bentler <- function(lavobject = NULL,
                                     lavsamplestats = NULL,
                                     lavmodel = NULL,
                                     lavimplied = NULL,
                                     lavoptions = NULL,
                                     lavdata = NULL,
                                     TEST.unscaled = NULL,
                                     E.inv = NULL,
                                     Delta = NULL,
                                     WLS.V = NULL,
                                     Gamma = NULL,
                                     test = "satorra.bentler",
                                     method = "original",
                                     ug2.old.approach = FALSE,
                                     return.u = FALSE,
                                     return.ugamma = FALSE) {
  TEST <- list()

  if (!is.null(lavobject)) {
    lavsamplestats <- lavobject@SampleStats
    lavmodel <- lavobject@Model
    lavoptions <- lavobject@Options
    lavimplied <- lavobject@implied
    lavdata <- lavobject@Data
    TEST$standard <- lavobject@test[[1]]
  } else {
    TEST$standard <- TEST.unscaled
  }
  npar <- lavmodel@nx.free

  # ug2.old.approach
  if (missing(ug2.old.approach)) {
    if (!is.null(lavoptions$ug2.old.approach)) {
      ug2.old.approach <- lavoptions$ug2.old.approach
    } else {
      ug2.old.approach <- FALSE
    }
  }

  # E.inv ok?
  if (length(lavoptions$information) == 1L &&
    length(lavoptions$h1.information) == 1L &&
    length(lavoptions$observed.information) == 1L) {
    E.inv.recompute <- FALSE
  } else if (
    (lavoptions$information[1] == lavoptions$information[2]) &&
      (lavoptions$h1.information[1] == lavoptions$h1.information[2]) &&
      (lavoptions$information[2] == "expected" ||
        (lavoptions$observed.information[1] ==
          lavoptions$observed.information[2]))) {
    E.inv.recompute <- FALSE
  } else {
    E.inv.recompute <- TRUE
    # change information options
    lavoptions$information[1] <- lavoptions$information[2]
    lavoptions$h1.information[1] <- lavoptions$h1.information[2]
    lavoptions$observed.information[1] <- lavoptions$observed.information[2]
  }
  if (!is.null(E.inv) && !is.null(WLS.V) && !is.null(Delta)) {
    E.inv.recompute <- FALSE # user-provided
  }

  # check test
  if (!all(test %in% c(
    "satorra.bentler",
    "scaled.shifted",
    "mean.var.adjusted"
  ))) {
    lav_msg_warn(gettext(
      "test must be one of `satorra.bentler', `scaled.shifted' or
      `mean.var.adjusted'; will use `satorra.bentler' only"))
    test <- "satorra.bentler"
  }

  if (return.u) {
    method <- "original"
  }

  # check method
  if (!all(method %in% c("original", "orthogonal.complement", "ABA"))) {
    lav_msg_warn(gettext("method must be one of `original', `ABA',
                         `orthogonal.complement'; will use `ABA'"))
    method <- "original"
  }

  # do we have E.inv, Delta, WLS.V?
  if (npar > 0L &&
    (is.null(E.inv) || is.null(Delta) || is.null(WLS.V) || E.inv.recompute)) {
    if (lavoptions$information.expected.mplus && lavoptions$estimator == "ML") {
      E <- lav_model_information_expected_MLM(
        lavmodel = lavmodel,
        augmented = FALSE, inverted = FALSE,
        lavsamplestats = lavsamplestats, extra = TRUE
      )
    } else {
      E <- lav_model_information(
        lavmodel = lavmodel,
        lavimplied = lavimplied,
        lavsamplestats = lavsamplestats, lavdata = lavdata,
        lavoptions = lavoptions, extra = TRUE
      )
    }
    E.inv <- try(lav_model_information_augment_invert(lavmodel,
      information = E, inverted = TRUE
    ), silent = TRUE)
    if (inherits(E.inv, "try-error")) {
      if (return.ugamma) {
        lav_msg_warn(gettext(
          "could not invert information matrix needed for UGamma"))
        return(NULL)
      } else if (return.u) {
        lav_msg_warn(gettext(
          "could not invert information matrix needed for UfromUGamma"))
        return(NULL)
      } else {
        TEST$standard$stat <- as.numeric(NA)
        TEST$standard$stat.group <- rep(as.numeric(NA), lavdata@ngroups)
        TEST$standard$pvalue <- as.numeric(NA)
        TEST[[test[1]]] <- c(TEST$standard,
          scaling.factor = as.numeric(NA),
          shift.parameter = as.numeric(NA),
          label = character(0)
        )
        lav_msg_warn(gettext("could not invert information matrix needed for
                             robust test statistic"))
        TEST[[test[1]]]$test <- test[1] # to prevent lavTestLRT error when robust test is detected for some but not all models
        return(TEST)
      }
    }
    Delta <- attr(E, "Delta")
    WLS.V <- attr(E, "WLS.V")
  }

  # catch df == 0
  if ((TEST$standard$df == 0L || TEST$standard$df < 0) &&
    !return.u && !return.ugamma) {
    TEST[[test[1]]] <- c(TEST$standard,
      scaling.factor = as.numeric(NA),
      label = character(0)
    )
    TEST[[test[1]]]$test <- test[1] # to prevent lavTestLRT error when robust test is detected for some but not all models
    return(TEST)
  }

  # Gamma
  if (is.null(Gamma)) {
    Gamma <- lavsamplestats@NACOV
    # still NULL? (perhaps estimator = ML)
    if (is.null(Gamma[[1]])) {
      if (!is.null(lavobject)) {
        Gamma <- lav_object_gamma(lavobject, model.based = FALSE)
      } else {
        Gamma <- lav_object_gamma(
          lavobject = NULL,
          lavdata = lavdata,
          lavoptions = lavoptions,
          lavsamplestats = lavsamplestats,
          lavh1 = NULL,
          lavimplied = NULL,
          ADF = TRUE,
          model.based = FALSE
        )
      }
    }
  }

  if (lavoptions$information.expected.mplus && lavmodel@categorical) {
    for (g in 1:lavsamplestats@ngroups) {
      Ng <- lavsamplestats@nobs[[g]]
      Gamma[[g]] <- Gamma[[g]] / Ng * (Ng - 1L)
    }
  }

  # ngroups
  ngroups <- lavsamplestats@ngroups

  # mean and variance adjusted?
  Satterthwaite <- FALSE
  if (any(test %in% c("mean.var.adjusted", "scaled.shifted"))) {
    Satterthwaite <- TRUE
  }

  if (npar == 0) {
    # catch npar == 0 (eg baseline model if correlation structure)
    trace.UGamma <- trace.UGamma2 <- U.all <- UG <- as.numeric(NA)
    fg <- unlist(lavsamplestats@nobs) / lavsamplestats@ntotal
    Gamma.f <- Gamma
    for (g in 1:ngroups) {
      Gamma.f[[g]] <- 1 / fg[g] * Gamma[[g]]
    }
    Gamma.all <- lav_matrix_bdiag(Gamma.f)
    UG <- Gamma.all
    trace.UGamma <- sum(diag(Gamma.all))
    trace.UGamma2 <- sum(UG * t(UG))
    out <- list(
      trace.UGamma = trace.UGamma, trace.UGamma2 = trace.UGamma2,
      UGamma = UG, UfromUGamma = U.all
    )
  } else if (method == "original") {
    out <- lav_test_satorra_bentler_trace_original(
      Gamma = Gamma,
      Delta = Delta, WLS.V = WLS.V, E.inv = E.inv,
      ngroups = ngroups, nobs = lavsamplestats@nobs,
      ntotal = lavsamplestats@ntotal, return.u = return.u,
      return.ugamma = return.ugamma,
      ug2.old.approach = ug2.old.approach,
      Satterthwaite = Satterthwaite
    )
  } else if (method == "orthogonal.complement") {
    out <- lav_test_satorra_bentler_trace_complement(
      Gamma = Gamma,
      Delta = Delta, WLS.V = WLS.V, lavmodel = lavmodel,
      ngroups = ngroups, nobs = lavsamplestats@nobs,
      ntotal = lavsamplestats@ntotal,
      return.ugamma = return.ugamma,
      ug2.old.approach = ug2.old.approach,
      Satterthwaite = Satterthwaite
    )
  } else if (method == "ABA") {
    out <- lav_test_satorra_bentler_trace_ABA(
      Gamma = Gamma,
      Delta = Delta, WLS.V = WLS.V, E.inv = E.inv,
      ngroups = ngroups, nobs = lavsamplestats@nobs,
      ntotal = lavsamplestats@ntotal,
      return.ugamma = return.ugamma,
      ug2.old.approach = ug2.old.approach,
      Satterthwaite = Satterthwaite
    )
  } else {
    lav_msg_stop(gettextf("method `%s' not supported", method))
  }
  trace.UGamma <- out$trace.UGamma
  trace.UGamma2 <- out$trace.UGamma2

  if ("satorra.bentler" %in% test) {
    # same df
    df.scaled <- TEST$standard$df

    # scaling factor
    scaling.factor <- trace.UGamma / df.scaled
    if (scaling.factor < 0) scaling.factor <- as.numeric(NA)

    # scaled test statistic per group
    stat.group <- TEST$standard$stat.group / scaling.factor

    # scaled test statistic global
    stat <- sum(stat.group)

    # label
    if (lavoptions$information.expected.mplus) {
      if (lavoptions$estimator == "ML") {
        label <-
          "Satorra-Bentler correction (Mplus variant)"
      } else if (lavoptions$estimator == "DWLS") {
        label <-
          "Satorra-Bentler correction (WLSM)"
      } else if (lavoptions$estimator == "ULS") {
        label <-
          "Satorra-Bentler correction (ULSM)"
      }
    } else {
      label <- "Satorra-Bentler correction"
    }

    TEST$satorra.bentler <-
      list(
        test = "satorra.bentler",
        stat = stat,
        stat.group = stat.group,
        df = df.scaled,
        pvalue = 1 - pchisq(stat, df.scaled),
        trace.UGamma = trace.UGamma,
        scaling.factor = scaling.factor,
        scaled.test.stat = TEST$standard$stat,
        scaled.test = TEST$standard$test,
        label = label
      )
  }

  if ("mean.var.adjusted" %in% test) {
    if (lavoptions$information.expected.mplus) {
      df.scaled <- floor(trace.UGamma^2 / trace.UGamma2 + 0.5)
    } else {
      # more precise, fractional df
      df.scaled <- trace.UGamma^2 / trace.UGamma2
    }

    # scaling factor
    scaling.factor <- trace.UGamma / df.scaled
    if (scaling.factor < 0) scaling.factor <- as.numeric(NA)

    if (ug2.old.approach) {
      # scaled test statistic per group
      stat.group <- TEST$standard$stat.group / scaling.factor

      # scaled test statistic global
      stat <- sum(stat.group)
    } else {
      # scaled test statistic per group
      stat.group <- TEST$standard$stat.group / scaling.factor

      # scaled test statistic global
      stat <- TEST$standard$stat / scaling.factor
    }

    # label
    if (lavoptions$information.expected.mplus) {
      if (lavoptions$estimator == "ML") {
        label <-
          "mean and variance adjusted correction (MLMV)"
      } else if (lavoptions$estimator == "DWLS") {
        label <-
          "mean and variance adjusted correction (WLSMV)"
      } else if (lavoptions$estimator == "ULS") {
        label <-
          "mean and variance adjusted correction (ULSMV)"
      }
    } else {
      label <- "mean and variance adjusted correction"
    }

    TEST$mean.var.adjusted <-
      list(
        test = "mean.var.adjusted",
        stat = stat,
        stat.group = stat.group,
        df = df.scaled,
        pvalue = 1 - pchisq(stat, df.scaled),
        trace.UGamma = trace.UGamma,
        trace.UGamma2 = trace.UGamma2,
        scaling.factor = scaling.factor,
        scaled.test.stat = TEST$standard$stat,
        scaled.test = TEST$standard$test,
        label = label
      )
  }

  if ("scaled.shifted" %in% test) {
    # this is the T3 statistic as used by Mplus 6 and higher
    # see 'Simple Second Order Chi-Square Correction' 2010
    # www.statmodel.com

    # same df
    df.scaled <- TEST$standard$df

    # scaling factor
    fg <- unlist(lavsamplestats@nobs) / lavsamplestats@ntotal
    a <- sqrt(df.scaled / trace.UGamma2)
    if (isTRUE(a < 0) || is.nan(a)) a <- as.numeric(NA)
    scaling.factor <- 1 / a
    if (isTRUE(scaling.factor < 0)) scaling.factor <- as.numeric(NA)

    if (ug2.old.approach) {
      # scaling factor
      shift.parameter <- fg * (df.scaled - a * trace.UGamma)
      # scaled test statistic per group
      stat.group <- (TEST$standard$stat.group * a + shift.parameter)
      # scaled test statistic global
      stat <- sum(stat.group)
    } else {
      shift.parameter <- df.scaled - a * trace.UGamma
      stat <- TEST$standard$stat * a + shift.parameter
      stat.group <- TEST$standard$stat.group * a + fg * shift.parameter
    }

    # label
    if (lavoptions$information.expected.mplus) {
      if (lavoptions$estimator == "ML") {
        label <-
          "simple second-order correction (MLMV)"
      } else if (lavoptions$estimator == "DWLS") {
        label <-
          "simple second-order correction (WLSMV)"
      } else if (lavoptions$estimator == "ULS") {
        label <-
          "simple second-order correction (ULSMV)"
      }
    } else {
      label <- "simple second-order correction"
    }

    TEST$scaled.shifted <-
      list(
        test = "scaled.shifted",
        stat = stat,
        stat.group = stat.group,
        df = df.scaled,
        pvalue = 1 - pchisq(stat, df.scaled),
        trace.UGamma = trace.UGamma,
        trace.UGamma2 = trace.UGamma2,
        scaling.factor = scaling.factor,
        shift.parameter = shift.parameter,
        scaled.test.stat = TEST$standard$stat,
        scaled.test = TEST$standard$test,
        label = label
      )
  }

  if (return.ugamma) {
    TEST$UGamma <- out$UGamma
  }

  if (return.u) {
    TEST$UfromUGamma <- out$UfromUGamma
  }

  TEST
}

# using the `classical' formula
# UG = Gamma * [V - V Delta E.inv Delta' V']
lav_test_satorra_bentler_trace_original <- function(Gamma = NULL,
                                                    Delta = NULL,
                                                    WLS.V = NULL,
                                                    E.inv = NULL,
                                                    ngroups = NULL,
                                                    nobs = NULL,
                                                    ntotal = NULL,
                                                    return.u = FALSE,
                                                    return.ugamma = FALSE,
                                                    ug2.old.approach = FALSE,
                                                    Satterthwaite = FALSE) {
  # this is what we did <0.6-13: everything per group
  if (ug2.old.approach) {
    UfromUGamma <- UG <- vector("list", ngroups)
    trace.UGamma <- trace.UGamma2 <- rep(as.numeric(NA), ngroups)
    for (g in 1:ngroups) {
      fg <- nobs[[g]] / ntotal
      Gamma.g <- Gamma[[g]] / fg ## ?? check this
      Delta.g <- Delta[[g]]
      if (is.matrix(WLS.V[[g]])) {
        WLS.Vg <- WLS.V[[g]] * fg
      } else {
        WLS.Vg <- diag(WLS.V[[g]]) * fg
      }

      U <- (WLS.Vg - WLS.Vg %*% Delta[[g]] %*% E.inv %*%
        t(Delta[[g]]) %*% WLS.Vg)
      trace.UGamma[g] <- sum(U * Gamma.g)

      if (return.u) {
        UfromUGamma[[g]] <- U
      }

      UG <- NULL
      if (Satterthwaite || return.ugamma) {
        UG.group <- U %*% Gamma.g
        trace.UGamma2[g] <- sum(UG.group * t(UG.group))
        UG[[g]] <- UG.group
      }
    } # g
    # sum over groups
    trace.UGamma <- sum(trace.UGamma)
    trace.UGamma2 <- sum(trace.UGamma2)
    U.all <- UfromUGamma # group-specific
  } else {
    trace.UGamma <- trace.UGamma2 <- U.all <- UG <- as.numeric(NA)
    fg <- unlist(nobs) / ntotal
    if (Satterthwaite || return.ugamma || return.u) {
      # for trace.UGamma2, we can no longer compute the trace per group
      V.g <- WLS.V
      for (g in 1:ngroups) {
        if (is.matrix(WLS.V[[g]])) {
          V.g[[g]] <- fg[g] * WLS.V[[g]]
        } else {
          V.g[[g]] <- fg[g] * diag(WLS.V[[g]])
        }
      }
      V.all <- lav_matrix_bdiag(V.g)
      Gamma.f <- Gamma
      for (g in 1:ngroups) {
        Gamma.f[[g]] <- 1 / fg[g] * Gamma[[g]]
      }
      Gamma.all <- lav_matrix_bdiag(Gamma.f)
      Delta.all <- do.call("rbind", Delta)
      U.all <- V.all - V.all %*% Delta.all %*% E.inv %*% t(Delta.all) %*% V.all
      UG <- U.all %*% Gamma.all

      trace.UGamma <- sum(U.all * Gamma.all)
      trace.UGamma2 <- sum(UG * t(UG))
    } else {
      # we only need trace.UGamma - this can be done group-specific
      trace.UGamma.group <- numeric(ngroups)
      for (g in 1:ngroups) {
        Gamma.g <- Gamma[[g]] / fg[g]
        Delta.g <- Delta[[g]]
        if (is.matrix(WLS.V[[g]])) {
          WLS.Vg <- WLS.V[[g]] * fg[g]
        } else {
          WLS.Vg <- diag(WLS.V[[g]]) * fg[g]
        }

        U <- (WLS.Vg - WLS.Vg %*% Delta[[g]] %*% E.inv %*%
          t(Delta[[g]]) %*% WLS.Vg)
        trace.UGamma.group[g] <- sum(U * Gamma.g)
      }
      trace.UGamma <- sum(trace.UGamma.group)
    }
  }

  list(
    trace.UGamma = trace.UGamma, trace.UGamma2 = trace.UGamma2,
    UGamma = UG, UfromUGamma = U.all
  )
}

# using the orthogonal complement of Delta: Delta.c
# UG = [ (Delta.c' W Delta.c)^{-1} (Delta.c' Gamma Delta.c)
lav_test_satorra_bentler_trace_complement <- function(Gamma = NULL,
                                                      Delta = NULL,
                                                      WLS.V = NULL,
                                                      lavmodel = NULL,
                                                      ngroups = NULL,
                                                      nobs = NULL,
                                                      ntotal = NULL,
                                                      return.ugamma = FALSE,
                                                      ug2.old.approach = FALSE,
                                                      Satterthwaite = FALSE) {
  # this is what we did <0.6-13: everything per group
  # does not work when ngroups > 1 + equality constraints
  if (ug2.old.approach) {
    UG <- vector("list", ngroups)
    trace.UGamma <- trace.UGamma2 <- rep(as.numeric(NA), ngroups)
    for (g in 1:ngroups) {
      fg <- nobs[[g]] / ntotal
      Gamma.g <- Gamma[[g]] / fg ## ?? check this
      Delta.g <- Delta[[g]]
      if (is.matrix(WLS.V[[g]])) {
        WLS.Vg <- WLS.V[[g]] * fg
      } else {
        WLS.Vg <- diag(WLS.V[[g]]) * fg
      }

      # handle equality constraints
      # FIXME: inequality constraints are ignored!
      if (lavmodel@eq.constraints) {
        Delta.g <- Delta.g %*% lavmodel@eq.constraints.K
      } else if (lavmodel@ceq.simple.only) {
        Delta.g <- Delta.g %*% lavmodel@ceq.simple.K
      }

      # orthogonal complement of Delta.g
      Delta.c <- lav_matrix_orthogonal_complement(Delta.g)

      ### FIXME: compute WLS.W directly, instead of using solve(WLS.V)

      tmp1 <- solve(t(Delta.c) %*% solve(WLS.Vg) %*% Delta.c)
      tmp2 <- t(Delta.c) %*% Gamma.g %*% Delta.c

      trace.UGamma[g] <- sum(tmp1 * tmp2)
      UG <- NULL
      if (Satterthwaite || return.ugamma) {
        UG.group <- tmp1 %*% tmp2
        trace.UGamma2[g] <- sum(UG.group * t(UG.group))
        UG[[g]] <- UG.group
      }
    }
    # sum over groups
    trace.UGamma <- sum(trace.UGamma)
    trace.UGamma2 <- sum(trace.UGamma2)
  } else {
    trace.UGamma <- trace.UGamma2 <- UG <- as.numeric(NA)
    fg <- unlist(nobs) / ntotal

    V.g <- WLS.V
    for (g in 1:ngroups) {
      if (is.matrix(WLS.V[[g]])) {
        V.g[[g]] <- fg[g] * WLS.V[[g]]
      } else {
        V.g[[g]] <- fg[g] * diag(WLS.V[[g]])
      }
    }
    V.all <- lav_matrix_bdiag(V.g)
    Gamma.f <- Gamma
    for (g in 1:ngroups) {
      Gamma.f[[g]] <- 1 / fg[g] * Gamma[[g]]
    }
    Gamma.all <- lav_matrix_bdiag(Gamma.f)
    Delta.all <- do.call("rbind", Delta)

    # handle equality constraints
    # FIXME: inequality constraints are ignored!
    if (lavmodel@eq.constraints) {
      Delta.all <- Delta.all %*% lavmodel@eq.constraints.K
    } else if (lavmodel@ceq.simple.only) {
      Delta.all <- Delta.all %*% lavmodel@ceq.simple.K
    }

    # orthogonal complement of Delta.g
    Delta.c <- lav_matrix_orthogonal_complement(Delta.all)

    tmp1 <- solve(t(Delta.c) %*% solve(V.all) %*% Delta.c)
    tmp2 <- t(Delta.c) %*% Gamma.all %*% Delta.c

    UG <- tmp1 %*% tmp2

    trace.UGamma <- sum(tmp1 * tmp2)
    trace.UGamma2 <- sum(UG * t(UG))
  }

  list(
    trace.UGamma = trace.UGamma, trace.UGamma2 = trace.UGamma2,
    UGamma = UG
  )
}

# using the ABA form
# UG = Gamma %*% [V - V %*% Delta %*% E.inv %*% tDelta %*% V]
#    = Gamma %*% V  - Gamma %*% V %*% Delta %*% E.inv %*% tDelta %*% V
#    = Gamma %*% A1 - Gamma %*% A1 %*% Delta %*% E.inv %*% tDelta %*% A1
# (define AGA1 := A1 %*% Gamma %*% A1)
# Note this is not identical to 'B1', (model-based) first-order information
#
#    = A1.inv %*% A1 %*% Gamma %*% A1 -
#      A1.inv %*% A1 %*% Gamma %*% A1 %*% Delta %*% E.inv %*% tDelta %*% A1
#
#    = A1.inv %*% AGA1 -
#      A1.inv %*% AGA1 %*% Delta %*% E.inv %*% tDelta %*% A1
#
# if only the trace is needed, we can use reduce the rhs (after the minus)
# to AGA1 %*% Delta %*% E.inv %*% tDelta (eliminating A1 and A1.inv)

# we write it like this to highlight the connection with MLR
#
lav_test_satorra_bentler_trace_ABA <- function(Gamma = NULL,
                                               Delta = NULL,
                                               WLS.V = NULL,
                                               E.inv = NULL,
                                               ngroups = NULL,
                                               nobs = NULL,
                                               ntotal = NULL,
                                               return.ugamma = FALSE,
                                               ug2.old.approach = FALSE,
                                               Satterthwaite = FALSE) {
  # this is what we did <0.6-13: everything per group
  if (ug2.old.approach) {
    UfromUGamma <- UG <- vector("list", ngroups)
    trace.UGamma <- trace.UGamma2 <- rep(as.numeric(NA), ngroups)

    for (g in 1:ngroups) {
      fg <- nobs[[g]] / ntotal
      Gamma.g <- Gamma[[g]] / fg ## ?? check this
      Delta.g <- Delta[[g]]

      # diagonal WLS.V? we check for this since 0.5-17
      diagonal <- FALSE
      if (is.matrix(WLS.V[[g]])) {
        A1 <- WLS.V[[g]] * fg
        AGA1 <- A1 %*% Gamma.g %*% A1
      } else {
        diagonal <- TRUE
        a1 <- WLS.V[[g]] * fg # numeric vector!
        AGA1 <- Gamma.g * tcrossprod(a1)
      }

      # note: we have AGA1 at the end, to avoid ending up with
      # a transposed matrix (both parts are non-symmetric)
      if (diagonal) {
        UG <- t(Gamma.g * a1) -
          (Delta.g %*% tcrossprod(E.inv, Delta.g) %*% AGA1)
      } else {
        UG <- (Gamma.g %*% A1) -
          (Delta.g %*% tcrossprod(E.inv, Delta.g) %*% AGA1)
      }

      trace.UGamma[g] <- sum(diag(UG))
      if (Satterthwaite) {
        trace.UGamma2[g] <- sum(UG * t(UG))
      }
    }
    # sum over groups
    trace.UGamma <- sum(trace.UGamma)
    trace.UGamma2 <- sum(trace.UGamma2)
  } else {
    trace.UGamma <- trace.UGamma2 <- UG <- as.numeric(NA)
    fg <- unlist(nobs) / ntotal
    if (Satterthwaite || return.ugamma) {
      # for trace.UGamma2, we can no longer compute the trace per group
      V.g <- WLS.V
      for (g in 1:ngroups) {
        if (is.matrix(WLS.V[[g]])) {
          V.g[[g]] <- fg[g] * WLS.V[[g]]
        } else {
          V.g[[g]] <- fg[g] * diag(WLS.V[[g]])
        }
      }
      V.all <- lav_matrix_bdiag(V.g)
      Gamma.f <- Gamma
      for (g in 1:ngroups) {
        Gamma.f[[g]] <- 1 / fg[g] * Gamma[[g]]
      }
      Gamma.all <- lav_matrix_bdiag(Gamma.f)
      Delta.all <- do.call("rbind", Delta)

      AGA1 <- V.all %*% Gamma.all %*% V.all

      UG <- (Gamma.all %*% V.all) -
        (Delta.all %*% tcrossprod(E.inv, Delta.all) %*% AGA1)

      trace.UGamma <- sum(diag(UG))
      trace.UGamma2 <- sum(UG * t(UG))
    } else {
      trace.UGamma.group <- numeric(ngroups)
      for (g in 1:ngroups) {
        fg <- nobs[[g]] / ntotal
        Gamma.g <- Gamma[[g]] / fg ## ?? check this
        Delta.g <- Delta[[g]]

        # diagonal WLS.V? we check for this since 0.5-17
        diagonal <- FALSE
        if (is.matrix(WLS.V[[g]])) {
          A1 <- WLS.V[[g]] * fg
          AGA1 <- A1 %*% Gamma.g %*% A1
        } else {
          diagonal <- TRUE
          a1 <- WLS.V[[g]] * fg # numeric vector!
          AGA1 <- Gamma.g * tcrossprod(a1)
        }

        # note: we have AGA1 at the end, to avoid ending up with
        # a transposed matrix (both parts are non-symmetric)
        if (diagonal) {
          UG <- t(Gamma.g * a1) -
            (Delta.g %*% tcrossprod(E.inv, Delta.g) %*% AGA1)
        } else {
          UG <- (Gamma.g %*% A1) -
            (Delta.g %*% tcrossprod(E.inv, Delta.g) %*% AGA1)
        }

        trace.UGamma.group[g] <- sum(diag(UG))
      } # g
      trace.UGamma <- sum(trace.UGamma.group)
    }
  }

  if (!return.ugamma) {
    UG <- NULL
  }

  list(
    trace.UGamma = trace.UGamma, trace.UGamma2 = trace.UGamma2,
    UGamma = UG
  )
}

# utility functions for the sam() function
# YR 4 April 2023

# construct 'mapping matrix' M using either "ML", "GLS" or "ULS" method
# optionally return MTM (for ML)
#
# by construction, M %*% LAMBDA = I (the identity matrix)
lav_sam_mapping_matrix <- function(LAMBDA = NULL, THETA = NULL,
                                   S = NULL, S.inv = NULL,
                                   method = "ML") {

  method <- toupper(method)

  # catch empty columns in LAMBDA (eg higher order!)
  LAMBDA.orig <- LAMBDA
  empty.idx <- which(apply(LAMBDA, 2L, function(x) all(x == 0)))
  if (length(empty.idx) > 0L) {
    LAMBDA <- LAMBDA.orig[, -empty.idx, drop = FALSE]
  }

  # ULS
  # M == solve( t(LAMBDA) %*% LAMBDA ) %*% t(LAMBDA)
  #   == MASS:::ginv(LAMBDA)
  if (method == "ULS") {
    # M == solve( t(LAMBDA) %*% LAMBDA ) %*% t(LAMBDA)
    #   == MASS:::ginv(LAMBDA)
    M <- try(tcrossprod(solve(crossprod(LAMBDA)), LAMBDA),
      silent = TRUE
    )
    if (inherits(M, "try-error")) {
      lav_msg_warn(gettext(
        "cannot invert crossprod(LAMBDA); using generalized inverse"))
      M <- MASS::ginv(LAMBDA)
    }


    # GLS
    # M == solve( t(LAMBDA) %*% S.inv %*% LAMBDA ) %*% t(LAMBDA) %*% S.inv
  } else if (method == "GLS") {
    if (is.null(S.inv)) {
      S.inv <- try(solve(S), silent = TRUE)
    }
    if (inherits(S.inv, "try-error")) {
      lav_msg_warn(gettext("S is not invertible; switching to ULS method"))
      M <- lav_sam_mapping_matrix(LAMBDA = LAMBDA, method = "ULS")
    } else {
      tLSinv <- t(LAMBDA) %*% S.inv
      tLSinvL <- tLSinv %*% LAMBDA
      M <- try(solve(tLSinvL, tLSinv), silent = TRUE)
      if (inherits(M, "try-error")) {
        lav_msg_warn(gettext("problem contructing mapping matrix;
                              switching to generalized inverse"))
        M <- MASS::ginv(tLSinvL) %*% tLSinv
      }
    }

    # ML
    # M == solve(t(LAMBDA) %*% THETA.inv %*% LAMBDA) %*% t(LAMBDA) %*% THETA.inv
  } else if (method == "ML") {
    # Problem: if THETA has zero elements on the diagonal, we cannot invert

    # As we do not have access to Sigma(.inv), we cannot
    # use the trick as in lavPredict() (where we replace THETA.inv by
    # Sigma.inv)

    # old method (<0.6-16): remove rows/cols with zero values
    # on the diagonal of THETA, invert the submatrix and
    # set the '0' diagonal elements to one. This resulted in (somewhat)
    # distorted results.

    # new in 0.6-16: we use the Wall & Amemiya (2000) method using
    # the so-called 'T' transformation

    # new in 0.6-18: if we cannot use the marker method (eg growth models),
    # use the 'old' method anyway: remove zero rows/cols and invert submatrix

    zero.theta.idx <- which(abs(diag(THETA)) < 1e-4) # be conservative
    if (length(zero.theta.idx) == 0L) {
      # ok, no zero diagonal elements: try to invert THETA
      if (lav_matrix_is_diagonal(THETA)) {
        THETA.inv <- diag(1 / diag(THETA), nrow = nrow(THETA))
      } else {
        THETA.inv <- try(solve(THETA), silent = TRUE)
        if (inherits(THETA, "try-error")) {
          THETA.inv <- NULL
        }
      }
    } else {
      # see if we can use marker method
      marker.idx <- lav_utils_get_marker(LAMBDA = LAMBDA, std.lv = TRUE)
      if (any(is.na(marker.idx))) {
        THETA.inv <- try(lav_matrix_symmetric_inverse(THETA), silent = TRUE)
        if (inherits(THETA.inv, "try-error")) {
          THETA.inv <- NULL
        } else {
          diag(THETA.inv)[zero.theta.idx] <- 1
        }
      } else {
        # try tmat method later on
        THETA.inv <- NULL
      }
    }

    # could we invert THETA?
    if (!is.null(THETA.inv)) {
      # ha, all is good; compute M the usual way
      tLTi <- t(LAMBDA) %*% THETA.inv
      tLTiL <- tLTi %*% LAMBDA
      M <- try(solve(tLTiL, tLTi), silent = TRUE)
      if (inherits(M, "try-error")) {
        lav_msg_warn(gettext(
          "problem contructing ML mapping matrix; switching to ULS"))
        M <- lav_sam_mapping_matrix(LAMBDA = LAMBDA, method = "ULS")
      }
    } else {
      # use W&A2000's method using the 'T' transformation
      M <- try(lav_sam_mapping_matrix_tmat(
        LAMBDA = LAMBDA,
        THETA = THETA
      ), silent = TRUE)
      if (inherits(M, "try-error")) {
        lav_msg_warn(gettext(
          "problem contructing ML mapping matrix; switching to ULS"))
        M <- lav_sam_mapping_matrix(LAMBDA = LAMBDA, method = "ULS")
      }
    }
  } # ML

  # empty.idx?
  if (length(empty.idx) > 0L) {
    M.full <- M
    M <- matrix(0, nrow = ncol(LAMBDA.orig), ncol = ncol(M.full))
    M[-empty.idx, ] <- M.full
  }

  M
}

# use 'T' transformation to create the 'Bartlett/ML' mapping matrix
# see Wall & Amemiya (2000) eq (7)
# see also Fuller 1987 page 357 (where T is called H), and page 364

# although Fuller/W&A always assumed that THETA is diagonal,
# their method seems to work equally well for non-diagonal THETA
#
# in our implementation:
# - we do NOT reorder the rows of LAMBDA
# - if std.lv = TRUE, we first rescale to 'create' marker indicators
#   and then rescale back at the end
#
lav_sam_mapping_matrix_tmat <- function(LAMBDA = NULL,
                                        THETA = NULL,
                                        marker.idx = NULL,
                                        std.lv = NULL) {

  LAMBDA <- as.matrix.default(LAMBDA)

  # catch empty columns in LAMBDA (eg higher order!)
  LAMBDA.orig <- LAMBDA
  empty.idx <- which(apply(LAMBDA, 2L, function(x) all(x == 0)))
  if (length(empty.idx) > 0L) {
    LAMBDA <- LAMBDA.orig[, -empty.idx, drop = FALSE]
  }

  nvar <- nrow(LAMBDA)
  nfac <- ncol(LAMBDA)

  # do we have marker.idx?
  if (is.null(marker.idx)) {
    # 'marker' indicator has a single non-zero element in a row
    marker.idx <- lav_utils_get_marker(LAMBDA = LAMBDA, std.lv = TRUE)
    if (any(is.na(marker.idx))) {
      lav_msg_stop(gettext("no clear markers in LAMBDA matrix"))
    }
  }

  # std.lv TRUE or FALSE?
  if (is.null(std.lv)) {
    std.lv <- FALSE
    if (any(diag(LAMBDA[marker.idx, , drop = FALSE]) != 1)) {
      std.lv <- TRUE
    }
  }

  # if std.lv = TRUE, rescale
  if (std.lv) {
    MARKER <- LAMBDA[marker.idx, , drop = FALSE]
    marker.inv <- 1 / diag(MARKER)
    LAMBDA <- t(t(LAMBDA) * marker.inv)
  }

  # compute 'T' matrix
  TMAT <- lav_sam_tmat(
    LAMBDA = LAMBDA, THETA = THETA,
    marker.idx = marker.idx
  )

  # ML mapping matrix
  M <- TMAT[marker.idx, , drop = FALSE]

  if (std.lv) {
    M <- M * marker.inv
  }

  # empty.idx?
  if (length(empty.idx) > 0L) {
    M.full <- M
    M <- matrix(0, nrow = ncol(LAMBDA.orig), ncol = ncol(M.full))
    M[-empty.idx, ] <- M.full
  }

  M
}

# create 'T' matrix (tmat) for T-transformation
#
# Notes: - here we assume that LAMBDA has unity markers (no std.lv = TRUE)
#        - TMAT is NOT symmetric!
#        - Yc %*% t(TMAT) transforms the data in such a way that we get:
#           1)  Bartlett factor scores in the marker columns
#           2) 'V' values in the non-marker columns, where:
#               V = Yc - Yc[,marker.idx] %*% t(LAMBDA)
#
lav_sam_tmat <- function(LAMBDA = NULL,
                         THETA = NULL,
                         marker.idx = NULL) {
  LAMBDA <- as.matrix.default(LAMBDA)
  nvar <- nrow(LAMBDA)
  nfac <- ncol(LAMBDA)

  # do we have marker.idx?
  if (is.null(marker.idx)) {
    # 'marker' indicator has a single 1 element in a row
    marker.idx <- lav_utils_get_marker(LAMBDA = LAMBDA, std.lv = FALSE)
    if (any(is.na(marker.idx))) {
      lav_msg_stop(gettext("no clear markers in LAMBDA matrix"))
    }
  }

  # construct 'C' matrix
  C2 <- diag(nvar)
  C2[, marker.idx] <- -1 * LAMBDA
  C <- C2[-marker.idx, , drop = FALSE]

  # compute Sigma.ve and Sigma.vv
  Sigma.ve <- C %*% THETA
  # Sigma.vv <- C %*% THETA %*% t(C)
  Sigma.vv <- Sigma.ve %*% t(C)

  # construct 'Gamma' (and Gamma2) matrix
  # Gamma <- (t(Sigma.ve) %*% solve(Sigma.vv))[marker.idx,, drop = FALSE]
  Gamma <- try(t(solve(Sigma.vv, Sigma.ve)[, marker.idx, drop = FALSE]),
    silent = TRUE
  )
  if (inherits(Gamma, "try-error")) {
    tmp <- t(Sigma.ve) %*% MASS::ginv(Sigma.vv)
    Gamma <- tmp[marker.idx, , drop = FALSE]
  }
  Gamma2 <- matrix(0, nfac, nvar)
  Gamma2[, -marker.idx] <- Gamma
  Gamma2[, marker.idx] <- diag(nfac)

  # transformation matrix 'T' (we call it here 'Tmat')
  Tmat <- matrix(0, nvar, nvar)
  Tmat[-marker.idx, ] <- C
  Tmat[marker.idx, ] <- -Gamma2 %*% C2

  Tmat
}


# compute VETA
# - if alpha.correction == 0     -> same as local SAM (or MOC)
# - if alpha.correction == (N-1) -> same as FSR+Bartlett
lav_sam_veta <- function(M = NULL, S = NULL, THETA = NULL,
                         alpha.correction = 0L, lambda.correction = TRUE,
                         N = 20L, dummy.lv.idx = integer(0L), extra = FALSE) {

  # catch empty rows in M (higher-order?)
  M.orig <- M
  empty.idx <- which(apply(M.orig, 1L, function(x) all(x == 0)))
  if (length(empty.idx) > 0L) {
    M <- M.orig[-empty.idx,, drop = FALSE]
  }

  # MSM
  MSM <- M %*% S %*% t(M)

  # MTM
  MTM <- M %*% THETA %*% t(M)

  # empty theta elements?
  empty.theta.idx <- which(diag(MTM) == 0)

  # new in 0.6-16: make sure MTM is pd
  # (otherwise lav_matrix_symmetric_diff_smallest_root will fail)
  theta.rm.idx <- unique(c(dummy.lv.idx, empty.theta.idx))
  if (length(theta.rm.idx) == nrow(MTM)) {
    # all zero?
    # do nothing, but certainly no need for alpha or lambda.correction
    alpha.correction = 0L
    lambda.correction = FALSE
  } else if (length(theta.rm.idx) > 0L) {
    MTM.small <- MTM[-theta.rm.idx, -theta.rm.idx, drop = FALSE]
    MTM.small <- zapsmall(lav_matrix_symmetric_force_pd(
      MTM.small,
      tol = 1e-04
    ))
    MTM[-theta.rm.idx, -theta.rm.idx] <- MTM.small
  } else {
    MTM <- zapsmall(lav_matrix_symmetric_force_pd(MTM, tol = 1e-04))
  }

  # apply small sample correction (if requested)
  if (alpha.correction > 0) {
    alpha.N1 <- alpha.correction / (N - 1)
    if (alpha.N1 > 1.0) {
      alpha.N1 <- 1.0
    } else if (alpha.N1 < 0.0) {
      alpha.N1 <- 0.0
    }
    MTM <- (1 - alpha.N1) * MTM
    alpha <- alpha.correction
  } else {
    alpha <- alpha.correction
  }

  lambda <- lambda.star <- +Inf
  if (lambda.correction) {
    # use Fuller (1987) approach to ensure VETA is positive
    lambda <- try(lav_matrix_symmetric_diff_smallest_root(MSM, MTM),
      silent = TRUE
    )
    if (inherits(lambda, "try-error")) {
      lav_msg_warn(gettext("failed to compute lambda"))
      VETA <- MSM - MTM # and hope for the best
    } else {
      cutoff <- 1 + 1 / (N - 1)
      if (lambda < cutoff) {
        lambda.star <- lambda - 1 / (N - 1)
        VETA <- MSM - lambda.star * MTM
      } else {
        VETA <- MSM - MTM
      }
    }
  } else {
    VETA <- MSM - MTM
  }

  # empty.idx?
  if (length(empty.idx) > 0L) {
    MSM.full <- MSM
    MTM.full <- MTM
    VETA.full <- VETA
    nfac.orig <- nrow(M.orig)

    MSM <- MTM <- VETA <- matrix(0, nrow = nfac.orig, ncol = nfac.orig)
    MSM[ -empty.idx, -empty.idx] <- MSM.full
    MTM[ -empty.idx, -empty.idx] <- MTM.full
    VETA[-empty.idx, -empty.idx] <- VETA.full
  }

  # extra attributes?
  if (extra) {
    attr(VETA, "lambda") <- lambda
    attr(VETA, "alpha") <- alpha
    attr(VETA, "lambda.star") <- lambda.star
	attr(VETA, "MSM") <- MSM
	attr(VETA, "MTM") <- MTM
  }

  VETA
}

# compute EETA = E(Eta) = M %*% [YBAR - NU]
lav_sam_eeta <- function(M = NULL, YBAR = NULL, NU = NULL) {
  EETA <- M %*% (YBAR - NU)
  EETA
}

# compute veta including quadratic/interaction terms
lav_sam_veta2 <- function(FS = NULL, M = NULL,
                          VETA = NULL, EETA = NULL, THETA = NULL,
                          lv.names = NULL,
                          lv.int.names = NULL,
                          dummy.lv.names = character(0L),
                          alpha.correction = 0L,
                          lambda.correction = TRUE,
                          fs.outlier.idx = integer(0L),
                          return.FS = FALSE,
                          return.cov.iveta2 = TRUE,
                          extra = FALSE) {

  # small utility function: var() divided by N
  varn <- function(x, N) {
    var(x, use = "pairwise.complete.obs") * (N - 1) / N
  }

  if (length(lv.int.names) == 0L) {
    lav_msg_stop(gettext("lv.int.names is empty: no lv quadratic/interaction
                         terms are provided"))
  }

  if (is.null(lv.names)) {
    lv.names <- paste("eta", seq_len(ncol(FS)), sep = "")
  }

  # MTM
  MTM <- M %*% THETA %*% t(M)

  # new in 0.6-16: make sure MTM is pd
  # (otherwise lav_matrix_symmetric_diff_smallest_root will fail)
  dummy.lv.idx <- which(lv.names %in% dummy.lv.names)
  if (length(dummy.lv.idx) > 0L) {
    MTM.nodummy <- MTM[-dummy.lv.idx, -dummy.lv.idx, drop = FALSE]
    MTM.nodummy <- zapsmall(lav_matrix_symmetric_force_pd(
      MTM.nodummy,
      tol = 1e-04
    ))
    MTM[-dummy.lv.idx, -dummy.lv.idx] <- MTM.nodummy
  } else {
    MTM <- zapsmall(lav_matrix_symmetric_force_pd(MTM, tol = 1e-04))
  }

  # augment to include intercept
  FS <- cbind(1, FS)
  N <- nrow(FS)
  MTM <- lav_matrix_bdiag(0, MTM)
  VETA <- lav_matrix_bdiag(0, VETA)
  EETA <- c(1, EETA)
  lv.names <- c("..int..", lv.names)
  nfac <- ncol(FS)

  idx1 <- rep(seq_len(nfac), each = nfac)
  idx2 <- rep(seq_len(nfac), times = nfac)

  NAMES <- paste(lv.names[idx1], lv.names[idx2], sep = ":")
  NAMES[seq_len(nfac)] <- lv.names

  FS2 <- FS[, idx1] * FS[, idx2]

  K.nfac <- lav_matrix_commutation(nfac, nfac)
  IK <- diag(nfac * nfac) + K.nfac

  EETA <- as.matrix(drop(EETA))
  VETAkMTM <- VETA %x% MTM

  # normal version (for now):
  Gamma.ME22 <- IK %*% (MTM %x% MTM)

  # ingredients (normal ME case)
  Var.FS2 <- varn(FS2, N)
  Var.ETAkME <- (tcrossprod(EETA) %x% MTM + VETAkMTM)
  Var.MEkETA <- lav_matrix_commutation_pre_post(Var.ETAkME)
  Var.ME2 <- Gamma.ME22

  cov.ETAkME.MEkETA <- lav_matrix_commutation_post(Var.ETAkME)
  cov.MEkETA.ETAkME <- t(cov.ETAkME.MEkETA)

  Var.ERROR <- (Var.ETAkME + Var.MEkETA + cov.ETAkME.MEkETA
    + cov.MEkETA.ETAkME + Var.ME2)

  # select only what we need
  colnames(Var.FS2) <- rownames(Var.FS2) <- NAMES
  colnames(Var.ERROR) <- rownames(Var.ERROR) <- NAMES
  colnames(FS2) <- NAMES
  lv.keep <- c(lv.names[-1], lv.int.names)
  Var.FS2 <- Var.FS2[lv.keep, lv.keep]
  Var.ERROR <- Var.ERROR[lv.keep, lv.keep]
  FS.mean <- colMeans(FS2, na.rm = TRUE)
  names(FS.mean) <- NAMES
  FS2.mean <- FS.mean # all of them
  FS.mean <- FS.mean[lv.keep]

  # compute Gamma for FS2[,lv.keep]
  #FS.gamma <- lav_samplestats_Gamma(FS2[,lv.keep, drop  = FALSE],
  #                                  meanstructure = TRUE)

  # apply small sample correction (if requested)
  if (alpha.correction > 0) {
    alpha.N1 <- alpha.correction / (N - 1)
    if (alpha.N1 > 1.0) {
      alpha.N1 <- 1.0
    } else if (alpha.N1 < 0.0) {
      alpha.N1 <- 0.0
    }
    Var.ERROR <- (1 - alpha.N1) * Var.ERROR
    alpha <- alpha.correction
  } else {
    alpha <- alpha.correction
  }

  lambda <- +Inf
  lambda.star <- 1
  if (lambda.correction) {
    # use Fuller (1987) approach to ensure VETA2 is positive
    lambda <- try(lav_matrix_symmetric_diff_smallest_root(
      Var.FS2,
      Var.ERROR
    ), silent = TRUE)
    if (inherits(lambda, "try-error")) {
      lav_msg_warn(gettext("failed to compute lambda"))
      VETA2 <- Var.FS2 - Var.ERROR # and hope for the best
    } else {
      #cutoff <- 1 + 1 / (N - 1)
	  cutoff <- 1 + 2/N # be more conservative for VETA2
      if (lambda < cutoff) {
        #lambda.star <- lambda - 1 / (N - 1)
		lambda.star <- max(c(0, lambda - ncol(Var.FS2)/(N - 1)))
        VETA2 <- Var.FS2 - lambda.star * Var.ERROR
      } else {
        VETA2 <- Var.FS2 - Var.ERROR
      }
    }
  } else {
    VETA2 <- Var.FS2 - Var.ERROR
  }

  # new in 0.6-20: to compute Gamma.eta
  if (return.cov.iveta2) {
    IVETA2 <- matrix(0, N, ncol = length(lav_matrix_vech(VETA2)) + ncol(VETA2))
    EF <- colMeans(FS)
    for(i in 1:N) {
      fi <- as.matrix(FS2[i,seq_len(nfac)])
      tmp <- ( ((tcrossprod(fi) - MTM) %x% MTM) +
           (MTM %x% (tcrossprod(fi) - MTM)) +
           lav_matrix_commutation_post((tcrossprod(fi) - MTM) %x% MTM) +
           lav_matrix_commutation_pre((tcrossprod(fi) - MTM) %x% MTM) +
           (IK %*% (MTM %x% MTM)) )
      iveta2 <- tcrossprod(FS2[i,] - FS2.mean) - lambda.star * tmp
      colnames(iveta2) <- rownames(iveta2) <- NAMES

      ieeta2 <- ( lav_matrix_vec(tcrossprod(fi)) -
                  lav_matrix_vec(tcrossprod(EF)) +
                  (EF %x% EF) -
                  lambda.star * lav_matrix_vec(MTM) )
      names(ieeta2) <- NAMES

      IVETA2[i,] <- c(ieeta2[lv.keep],
                      lav_matrix_vech(iveta2[lv.keep, lv.keep]))
    } # N
    # experimental:
    # remove outliers in FS?
    #if (length(fs.outlier.idx) > 0L) {
    #  IVETA2 <- IVETA2[-fs.outlier.idx, ,drop = FALSE]
    #  N <- N - length(fs.outlier.idx)
    #}
    cov.iveta2 <- cov(IVETA2) * (N-1)/N
  }

  # extra attributes?
  if (extra) {
    attr(VETA2, "lambda") <- lambda
    attr(VETA2, "alpha") <- alpha
    attr(VETA2, "lambda.star") <- lambda.star
    attr(VETA2, "MSM") <- Var.FS2
    attr(VETA2, "MTM") <- Var.ERROR
	attr(VETA2, "FS.mean") <- FS.mean
    #attr(VETA2, "FS.gamma") <- FS.gamma
  }
  if (return.FS) {
    attr(VETA2, "FS") <- FS2[, lv.keep, drop = FALSE]
  }
  if (return.cov.iveta2) {
    attr(VETA2, "cov.iveta2") <- cov.iveta2
  }

  VETA2
}

lav_sam_eeta2 <- function(EETA = NULL, VETA = NULL, lv.names = NULL,
                          lv.int.names = NULL) {
  if (length(lv.int.names) == 0L) {
    lav_msg_stop(gettext("lv.int.names is empty: no lv quadratic/interaction
                         terms are provided"))
  }

  if (is.null(lv.names)) {
    lv.names <- paste("eta", seq_len(ncol(VETA)), sep = "")
  }

  nfac <- nrow(VETA)
  idx1 <- rep(seq_len(nfac), each = nfac)
  idx2 <- rep(seq_len(nfac), times = nfac)
  NAMES <- c(lv.names, paste(lv.names[idx1], lv.names[idx2], sep = ":"))

  # E(\eta %x% \eta)
  EETA2 <- lav_matrix_vec(VETA) + EETA %x% EETA

  # add 1st order
  EETA2.aug <- c(EETA, EETA2)

  # select only what we need
  names(EETA2.aug) <- NAMES
  lv.keep <- c(lv.names, lv.int.names)
  EETA2.aug <- EETA2.aug[lv.keep]

  EETA2.aug
}

# compute var(fs2) including quadratic/interaction terms
lav_sam_fs2 <- function(FS = NULL, lv.names = NULL, lv.int.names = NULL) {
  varn <- function(x, N) {
    var(x) * (N - 1) / N
  }

  if (length(lv.int.names) == 0L) {
    lav_msg_stop(gettext("lv.int.names is empty: no lv quadratic/interaction
                         terms are provided"))
  }

  if (is.null(lv.names)) {
    lv.names <- paste("eta", seq_len(ncol(FS)), sep = "")
  }

  # augment to include intercept
  FS <- cbind(1, FS)
  N <- nrow(FS)
  lv.names <- c("..int..", lv.names)
  nfac <- ncol(FS)

  idx1 <- rep(seq_len(nfac), each = nfac)
  idx2 <- rep(seq_len(nfac), times = nfac)

  NAMES <- paste(lv.names[idx1], lv.names[idx2], sep = ":")

  FS2 <- FS[, idx1] * FS[, idx2]
  Var.FS2 <- varn(FS2, N)

  # select only what we need
  colnames(Var.FS2) <- rownames(Var.FS2) <- NAMES
  lv.main <- paste(lv.names[-1], "..int..", sep = ":")
  lv.keep <- c(lv.main, lv.int.names)
  Var.FS2 <- Var.FS2[lv.keep, lv.keep]

  Var.FS2
}

# create consistent lavaan object, based on (filled in) PT
lav_sam_step3_joint <- function(FIT = NULL, PT = NULL, sam.method = "local") {
  lavoptions <- FIT@Options

  lavoptions.joint <- lavoptions
  lavoptions.joint$optim.method <- "none"
  lavoptions.joint$optim.parscale <- "none"
  lavoptions.joint$start <- "default"
  lavoptions.joint$optim.force.converged <- TRUE
  lavoptions.joint$check.gradient <- FALSE
  lavoptions.joint$check.start <- FALSE
  lavoptions.joint$check.post <- FALSE
  lavoptions.joint$rotation <- "none"
  lavoptions.joint$se <- "none"
  lavoptions.joint$store.vcov <- FALSE # we do this manually

  if (sam.method %in% c("local", "fsr", "cfsr")) {
    lavoptions.joint$baseline <- FALSE
    lavoptions.joint$sample.icov <- FALSE
    #lavoptions.joint$h1 <- TRUE # we need this if we re-use the sam object
    lavoptions.joint$test <- "none"
    lavoptions.joint$estimator <- "none"
  } else {
    lavoptions.joint$test <- lavoptions$test
    lavoptions.joint$estimator <- lavoptions$estimator
  }

  # set ustart values
  PT$ustart <- PT$est # as this is used if optim.method == "none"

  JOINT <- lavaan::lavaan(PT,
    slotOptions = lavoptions.joint,
    slotSampleStats = FIT@SampleStats,
    slotData = FIT@Data,
    verbose = FALSE
  )
  JOINT
}

lav_sam_table <- function(JOINT = NULL, STEP1 = NULL, FIT.PA = NULL,
                          cmd = NULL, lavoptions = NULL,
                          mm.args = list(), struc.args = list(),
                          sam.method = "local",
                          local.options = list(), global.options = list()) {
  MM.FIT <- STEP1$MM.FIT

  sam.mm.table <- data.frame(
    Block = seq_len(length(STEP1$mm.list)),
    Latent = sapply(MM.FIT, function(x) {
      paste(unique(unlist(x@pta$vnames$lv)), collapse = ",")
    }),
    Nind = sapply(MM.FIT, function(x) {
      length(unique(unlist(x@pta$vnames$ov)))
    }),
    # Estimator = sapply(MM.FIT, function(x) { x@Model@estimator} ),
    Chisq = sapply(MM.FIT, function(x) {
      x@test[[1]]$stat
    }),
    Df = sapply(MM.FIT, function(x) {
      x@test[[1]]$df
    })
  )
  # pvalue = sapply(MM.FIT, function(x) {x@test[[1]]$pvalue}) )
  class(sam.mm.table) <- c("lavaan.data.frame", "data.frame")


  # extra info for @internal slot
  if (sam.method %in% c("local", "fsr", "cfsr")) {
    sam.struc.fit <- try(
      fitMeasures(
        FIT.PA,
        c(
          "chisq", "df", # "pvalue",
          "cfi", "rmsea", "srmr"
        )
      ),
      silent = TRUE
    )
    if (inherits(sam.struc.fit, "try-error")) {
      sam.struc.fit <- "(unable to obtain fit measures)"
      names(sam.struc.fit) <- "warning"
    }
    sam.mm.rel <- STEP1$REL
  } else {
    sam.struc.fit <- "no local fit measures available for structural part if sam.method is global"
    names(sam.struc.fit) <- "warning"
    sam.mm.rel <- numeric(0L)
  }


  SAM <- list(
    sam.cmd = cmd,
    sam.method = sam.method,
    sam.local.options = local.options,
    sam.global.options = global.options,
    sam.mm.list = STEP1$mm.list,
    sam.mm.estimator = MM.FIT[[1]]@Model@estimator,
    sam.mm.args = mm.args,
    sam.mm.ov.names = lapply(MM.FIT, function(x) {
      x@pta$vnames$ov
    }),
    sam.mm.table = sam.mm.table,
    sam.mm.rel = sam.mm.rel,
    sam.struc.estimator = FIT.PA@Model@estimator,
    sam.struc.args = struc.args,
    sam.struc.fit = sam.struc.fit,
    sam.lavoptions = lavoptions
  )
  SAM
}

lav_sam_get_cov_ybar <- function(FIT = NULL, local.options = list(
                                  M.method = "ML",
                                  lambda.correction = TRUE,
                                  alpha.correction = 0L,
                                  twolevel.method = "h1"
                                )) {

  # local.twolevel.method
  local.twolevel.method <- tolower(local.options[["twolevel.method"]])
  if (!local.twolevel.method %in% c("h1", "anova", "mean")) {
    lav_msg_stop(gettext(
      "local option twolevel.method should be one of h1, anova or mean."))
  }

  local.M.method <- toupper(local.options[["M.method"]])

  lavpta <- FIT@pta
  ngroups <- lavpta$ngroups
  nlevels <- lavpta$nlevels
  nblocks <- lavpta$nblocks

  # do we need H1?
  if (nlevels > 1L && local.twolevel.method == "h1") {
    H1 <- lav_h1_implied_logl(
      lavdata = FIT@Data,
      lavsamplestats = FIT@SampleStats,
      lavoptions = FIT@Options
    )
    h1implied <- H1$implied
  } else {
    h1implied <- FIT@h1$implied
    # if (FIT@Options$conditional.x) {
    #   h1implied <- lav_model_implied_cond2uncond(h1implied)
    # }
  }

  # containers
  COV.list  <- vector("list", nblocks)
  YBAR.list <- vector("list", nblocks)

  # label
  if (nblocks > 1L) {
    names(COV.list)  <- FIT@Data@block.label
    names(YBAR.list) <- FIT@Data@block.label
  }

  # collect COV/YBAR per block
  for (b in seq_len(nblocks)) {

    # get sample statistics for this block
    if (nlevels > 1L) {
      if (ngroups > 1L) {
        this.level <- (b - 1L) %% ngroups + 1L
      } else {
        this.level <- b
      }
      this.group <- floor(b / nlevels + 0.5)

      if (this.level == 1L) {
        if (local.twolevel.method == "h1") {
          COV <- h1implied$cov[[1]]
          YBAR <- h1implied$mean[[1]]
        } else if (local.twolevel.method == "anova" ||
          local.twolevel.method == "mean") {
          COV <- FIT@SampleStats@YLp[[this.group]][[2]]$Sigma.W
          YBAR <- FIT@SampleStats@YLp[[this.group]][[2]]$Mu.W
        }

        # reduce
        ov.idx <- FIT@Data@Lp[[this.group]]$ov.idx[[this.level]]
        COV <- COV[ov.idx, ov.idx, drop = FALSE]
        YBAR <- YBAR[ov.idx]
      } else if (this.level == 2L) {
        if (local.twolevel.method == "h1") {
          COV <- h1implied$cov[[2]]
          YBAR <- h1implied$mean[[2]]
        } else if (local.twolevel.method == "anova") {
          COV <- FIT@SampleStats@YLp[[this.group]][[2]]$Sigma.B
          YBAR <- FIT@SampleStats@YLp[[this.group]][[2]]$Mu.B
        } else if (local.twolevel.method == "mean") {
          S.PW <- FIT@SampleStats@YLp[[this.group]][[2]]$Sigma.W
          NJ <- FIT@SampleStats@YLp[[this.group]][[2]]$s
          Y2 <- FIT@SampleStats@YLp[[this.group]][[2]]$Y2
          # grand mean
          MU.Y <- (FIT@SampleStats@YLp[[this.group]][[2]]$Mu.W + FIT@SampleStats@YLp[[this.group]][[2]]$Mu.B)
          Y2c <- t(t(Y2) - MU.Y) # MUST be centered
          YB <- crossprod(Y2c) / nrow(Y2c)
          COV <- YB - 1 / NJ * S.PW
          YBAR <- FIT@SampleStats@YLp[[this.group]][[2]]$Mu.B
        }

        # reduce
        ov.idx <- FIT@Data@Lp[[this.group]]$ov.idx[[this.level]]
        COV <- COV[ov.idx, ov.idx, drop = FALSE]
        YBAR <- YBAR[ov.idx]
      } else {
        lav_msg_stop(gettext("level 3 not supported (yet)."))
      }

      # single level
    } else {
      this.group <- b
      if (FIT@Model@conditional.x) {
        YBAR <- h1implied$res.int[[b]]
        COV  <- h1implied$res.cov[[b]]
      } else {
        YBAR <- h1implied$mean[[b]] # EM version if missing="ml"
        COV  <- h1implied$cov[[b]]
      }
    } # single level

    COV.list[[b]] <- COV
    YBAR.list[[b]] <- YBAR
  }

  list(COV = COV.list, YBAR = YBAR.list)
}

# automatically generate mm.list; we create measurement blocks so that:
# - unlinked factors become a singleton
# - linked factor are joined into a single measurement block
#   based: cross-loadings, or correlated residuals between item errors
lav_sam_get_mmlist <- function(lavobject) {

  lavmodel <- lavobject@Model
  lavpta <- lavobject@pta
  nblocks <- lavpta$nblocks

  # flags
  lv.interaction.flag <- FALSE
  lv.higherorder.flag <- FALSE
  if (length(unlist(lavpta$vnames$lv.interaction)) > 0L) {
    lv.interaction.flag <- TRUE
  }
  if (length(unlist(lavpta$vnames$lv.ind)) > 0L) {
    lv.higherorder.flag <- TRUE
  }

  lambda.idx <- which(names(lavmodel@GLIST) == "lambda")

  mm.list <- vector("list", length = nblocks)

  GLIST <- lavTech(lavobject, "partable")
  for (b in seq_len(nblocks)) {
    mm.in.block <- (seq_len(lavmodel@nmat[b]) +
        cumsum(c(0, lavmodel@nmat))[b])
    MLIST <- GLIST[mm.in.block]
    CC <- t(MLIST$lambda) %*% MLIST$theta %*% MLIST$lambda

    # note: CC contains dummy lv's, higher-order, etc... and they
    # must be removed

    # get ALL lv names (including dummy ov.x/ov.y)
    ov.names <- lavmodel@dimNames[[lambda.idx[b]]][[1L]]
    lv.names <- lavmodel@dimNames[[lambda.idx[b]]][[2L]]
    NAMES <- lv.names

    # needs to removed:
    # - all lv.ind variables
    # - all higher-order latent variables
    # - all dummy lv's
    rm.idx <- c(match(lavpta$vnames$lv.ind[[b]], lv.names),
                match(lavpta$vnames$lv.interaction[[b]], lv.names),
                which(lv.names %in% ov.names))
    if (length(rm.idx) > 0L) {
      CC <- CC[-rm.idx, -rm.idx, drop = FALSE]
      NAMES <- lv.names[-rm.idx]
    }

    # cluster membership
    membership <- lav_graph_get_connected_nodes(CC)

    out <- split(NAMES, NAMES[membership])
    names(out) <- paste("block", seq_len(length(out)), sep = "")

    mm.list[[b]] <- out
  }

  mm.list
}

lav_sam_veta_partable <- function(lavobject, block = 1L) {

  lavmodel <- lavobject@Model
  lavpta   <- lavobject@pta
  nblocks  <- lavpta$nblocks

  lambda.idx <- which(names(lavmodel@GLIST) == "lambda")

  GLIST <- lavTech(lavobject, "partable")
  b <- block
  mm.in.block <- (seq_len(lavmodel@nmat[b]) + cumsum(c(0, lavmodel@nmat))[b])
  MLIST <- GLIST[mm.in.block]
  PSI    <- (MLIST$psi    != 0) + 0L
  nr <- nrow(MLIST$psi)
  if (!is.null(MLIST$beta)) {
    BETA <- (MLIST$beta != 0) + 0L
    tmp <- -BETA
    tmp[lav_matrix_diag_idx(nr)] <- 1
    IB.inv <- solve(tmp)
  } else {
    IB.inv <- diag(nr)
  }
  VETA <- IB.inv %*% PSI %*% t(IB.inv)
  # get ALL lv names (including dummy ov.x/ov.y)
  lv.names <- lavmodel@dimNames[[lambda.idx[b]]][[2L]]
  colnames(VETA) <- rownames(VETA) <- lv.names

  VETA
}

lav_sam_veta_con <- function(S = NULL, LAMBDA = NULL, THETA = NULL,
                             L.veta = NULL, local.M.method = "ML",
                             tol = 1e-07, max.iter = 100L) {

  # first do GLS/ULS
  M <- ncol(LAMBDA)
  if (local.M.method == "ULS") {
    W <- diag(M)
  } else {
    W <- solve(S)
  }

  WL <- W %*% LAMBDA
  tLW  <- t(WL)
  tLWL <- tLW %*% LAMBDA
  tmp1 <- t(L.veta) %*% (tLWL %x% tLWL) %*% L.veta
  tmp2 <- t(L.veta) %*% lav_matrix_vec(tLW %*% (S - THETA) %*% WL)
  out <- solve(tmp1, tmp2)
  VETA.init <- matrix(L.veta %*% out, M, M)

  if (local.M.method != "ML") {
    # we are done!
    return(VETA.init)
  }

  VETA.new <- VETA.init
  for(i in seq_len(max.iter)) {
    Sigma.ml <- LAMBDA %*% VETA.new %*% t(LAMBDA) + THETA
    W <- solve(Sigma.ml)
    WL <- W %*% LAMBDA
    tLW  <- t(WL)
    tLWL <- tLW %*% LAMBDA
    tmp1 <- t(L.veta) %*% (tLWL %x% tLWL) %*% L.veta
    tmp2 <- t(L.veta) %*% lav_matrix_vec(tLW %*% (S - THETA) %*% WL)
    out <- solve(tmp1, tmp2)
    VETA.ml <- matrix(L.veta %*% out, M, M)
    rmsea <- sqrt(sum((VETA.new - VETA.ml)^2))
    #cat("i = ", i, " rmsea = ", rmsea, "\n")
    VETA.new <- VETA.ml
    if (rmsea < tol) {
      break
    }
  }

  VETA.new
}



# only compute 'H1' (=unrestricted/saturated) sample statistics
# (which usually go into the lavh1 slot) (and perhaps some extras, like icc)
#
# YR 14 June 2024: initial version

lavH1 <- function(object, # nolint
                  # lavdata options
                  ordered = NULL,
                  sampling.weights = NULL,
                  group = NULL,
                  cluster = NULL,
                  ov.names.x = character(0L),
                  ov.names.l = list(),
                  # other options (for lavaan)
                  ...,
                  output = "h1",
                  add.extra = TRUE,
                  # lavInspect() options
                  add.labels = TRUE,
                  add.class = TRUE,
                  drop.list.single.group = TRUE) {

  # shortcut if object = lavaan object
  if (inherits(object, "lavaan")) {
    lavh1 <- lavInspect(object, "h1")
    # if multilevel: add icc
    if (add.extra && object@Data@nlevels > 1L) {
      lavh1$icc <- lavInspect(object, "icc",
        add.labels = add.labels,
        add.class = add.class, drop.list.single.group = drop.list.single.group
      )
    }
    return(lavh1)
  }

  # output
  output <- tolower(output)

  # dotdotdot
  dotdotdot <- list(...)

  # verbose?
  if (!is.null(dotdotdot$verbose)) {
    if (dotdotdot$verbose) {
      lav_verbose(TRUE)
    }
    dotdotdot$verbose <- NULL
  }

  # check object class
  if (inherits(object, "lavData")) {
    lavdata <- object
  } else if (inherits(object, "data.frame") ||
    inherits(object, "matrix")) {
    object <- as.data.frame(object)
  } else {
    lav_msg_stop(
      gettext("lavH1 can not handle objects of class"),
      paste(class(object), collapse = " ")
    )
  }

  # prepare to create lavdata object
  if (inherits(object, "lavData")) {
    ov.names <- unique(unlist(lavdata@ov.names))
    ov.names.x <- unique(unlist(lavdata@ov.names.x))
    ordered <- lavdata@ordered
    ov.names.l <- lavdata@ov.names.l
    group <- lavdata@group
    cluster <- lavdata@cluster
    dotdotdot@missing <- lavdata@missing

    # just a regular data.frame
  } else {
    # ov.names
    ov.names <- names(object)
    if (!is.null(group)) {
      ov.names <- ov.names[-match(group, ov.names)]
    }
    if (!is.null(cluster)) {
      ov.names <- ov.names[-match(cluster, ov.names)]
    }
    if (!is.null(sampling.weights)) {
      ov.names <- ov.names[-match(sampling.weights, ov.names)]
    }
    if (!is.null(dotdotdot$conditional.x) && dotdotdot$conditional.x) {
      if (length(ov.names.x) == 0L) {
        lav_msg_stop(
          gettext("conditional.x = TRUE, but ov.names.x is empty")
        )
      }
      ov.names.x <- unique(unlist(ov.names.x))
      ov.names <- ov.names[-match(ov.names.x, ov.names)]
    }

    # ordered
    if (is.logical(ordered) && ordered) {
      ordered <- ov.names
    } else if (is.null(ordered) ||
      (length(ordered) == 1L && nchar(ordered) == 0L)) {
      # check data
      ordered <- ov.names[sapply(object, is.ordered)]
    } else if (!is.character(ordered)) {
      lav_msg_stop(gettext("ordered argument must be a character vector"))
    }

    if (length(ordered) > 0L) {
      # check if all names in "ordered" occur in the dataset?
      missing.idx <- which(!ordered %in% ov.names)
      if (length(missing.idx) > 0L) {
        lav_msg_warn(gettextf("ordered variable(s): %s could not be found
          in the data and will be ignored", lav_msg_view(ordered[missing.idx])))
      }
      # if ov.names.x, remove them from ordered (sanity check)
      if (length(ov.names.x) > 0L) {
        rm.idx <- which(ordered %in% ov.names.x)
        if (length(rm.idx) > 0L) {
          ordered <- ordered[-rm.idx]
        }
      }
    }

    # group/cluster
    if (!is.null(cluster)) {
      ngroups <- 1L
      if (!is.null(group)) {
        ngroups <- length(unique(object[, group]))
      }
      if (is.null(ov.names.l) || length(ov.names.l) == 0L) {
        ov.names.l <- vector("list", ngroups)
        # only two levels for now
        for (g in seq_len(ngroups)) {
          ov.names.l[[g]] <- vector("list", 2L)
          ov.names.l[[g]][[1]] <- ov.names
          ov.names.l[[g]][[2]] <- ov.names
        }
      } else {
        # check ov.names.l
        if (!is.list(ov.names.l)) { # just a single vector of names?
          ov.names.l <- rep(list(ov.names.l), 2L) # twolevels
        } else if (length(ov.names.l) == ngroups &&
          is.list(ov.names.l[[ngroups]])) {
        } else {
          ov.names.l <- rep(list(ov.names.l), ngroups)
        }
        tmp <- unique(unlist(ov.names.l))
        if (!all(tmp %in% ov.names)) {
          lav_msg_stop(gettextf(
            "some variable names in ov.names.l
            are missing: %1$s",
            lav_msg_view(tmp[!tmp %in% ov.names])
          ))
        }
      }
    }
  } # object = data

  # lavoptions
  lavoptions <- lav_lavaan_step02_options(
    slotOptions = NULL, # nolint
    slotData = NULL, # nolint
    flat.model = NULL,
    ordered = ordered,
    sample.cov = NULL,
    sample.mean = NULL,
    sample.th = NULL,
    sample.nobs = NULL,
    ov.names.l = ov.names.l,
    sampling.weights = sampling.weights,
    constraints = NULL,
    group = group,
    ov.names.x = ov.names.x,
    ov.names.y = ov.names[!ov.names %in% ov.names.x],
    dotdotdot = dotdotdot,
    cluster = cluster,
    data = "not.null"
  )

  # annoying: ov.names should not contain ov.names.x if categorical
  if (length(ordered) > 0L && lavoptions$conditional.x) {
    rm.idx <- which(ov.names %in% ov.names.x)
    if (length(rm.idx) > 0L) {
      ov.names <- ov.names[-rm.idx]
    }
  }

  # create lavdata (if needed)
  if (!inherits(object, "lavdata")) {
    lavdata <- lav_lavdata(
      data = object, group = group, cluster = cluster,
      ov.names = ov.names, ordered = ordered,
      sampling.weights = sampling.weights,
      ov.names.x = ov.names.x, ov.names.l = ov.names.l,
      lavoptions = lavoptions
    )
  }

  # create SampleStats (needed for multilevel - YLp slot)
  lavsamplestats <- lav_samplestats_from_data(
    lavdata = lavdata,
    lavoptions = lavoptions
  )

  # generate partable for unrestricted model
  lavpartable.un <- lav_partable_unrestricted(
    lavobject = NULL,
    lavdata = lavdata,
    lavsamplestats = lavsamplestats,
    lavh1 = NULL,
    lavoptions = lavoptions
  )

  # override some options
  lavoptions$h1 <- TRUE
  lavoptions$model.type <- "unrestricted"
  lavoptions$start <- "simple" # we have a full ustart column in lavpartable.un
  if (output != "lavaan") {
    lavoptions$implied <- FALSE
    lavoptions$loglik <- FALSE
    lavoptions$postcheck <- FALSE
    lavoptions$bounds <- "none"
    lavoptions$optim.method <- "none"
    lavoptions$estimator <- "none"
    lavoptions$se <- "none"
    lavoptions$test <- "none"
    lavoptions$baseline <- FALSE
  }

  # create lavaan object (usually without fitting)
  lavobject <- lavaan(
    slotParTable = lavpartable.un, slotData = lavdata,
    slotSampleStats = lavsamplestats, slotOptions = lavoptions
  )

  output <- tolower(output)
  if (output == "lavaan") {
    return(lavobject)
  } else {
    lavh1 <- lav_object_inspect_sampstat(
      object = lavobject, h1 = TRUE,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group
    )

    # add additional info?

    # if multilevel: add icc
    if (add.extra && lavobject@Data@nlevels > 1L) {
      lavh1$icc <- lavInspect(lavobject, "icc",
        add.labels = add.labels,
        add.class = add.class, drop.list.single.group = drop.list.single.group
      )
    }
  }

  lavh1
}

# keep 'old' names for some function names that have been used
# (or are still being used) by external packages
# rsem
computeExpectedInformation <- lav_model_information_expected      # nolint start
# only for simsem ....
getParameterLabels <- lav_partable_labels

# standardize function names in lav_utils.R / 31 Oct 2025
getCov <- function(x, lower = TRUE, diagonal = TRUE, sds = NULL,
                   names = paste("V", 1:nvar, sep = "")) {
  lav_deprecated("lav_getcov")
  if (diagonal) {
    nvar <- (sqrt(1 + 8 * length(x)) - 1)/2
  }
  else {
    nvar <- (sqrt(1 + 8 * length(x)) + 1)/2
  }
  sc <- sys.call()
  sc[[1L]] <- quote(lavaan::lav_getcov)
  eval(sc, parent.frame())
}
char2num <- function(s = "") {
    lav_deprecated("lav_char2num")
    sc <- sys.call()
    sc[[1L]] <- quote(lavaan::lav_char2num)
    eval(sc, parent.frame())
}
cor2cov <- function(R, sds, names = NULL) {
    lav_deprecated("lav_cor2cov")
    sc <- sys.call()
    sc[[1L]] <- quote(lavaan::lav_cor2cov)
    eval(sc, parent.frame())
}

# standardize function names in lav_mplus_lavaan / 7 Nov 2025
mplus2lavaan.modelSyntax <- function(syntax) {
    lav_deprecated("lav_mplus_syntax_model")
    sc <- sys.call()
    sc[[1L]] <- quote(lavaan::lav_mplus_syntax_model)
    eval(sc, parent.frame())
}
mplus2lavaan  <- function(inpfile, run = TRUE)  {
    lav_deprecated("lav_mplus_lavaan")
    sc <- sys.call()
    sc[[1L]] <- quote(lavaan::lav_mplus_lavaan)
    eval(sc, parent.frame())
}

# standardize function names in lav_partable_vnames.R / 9 December 2025
lavaanNames <- function(object, type = "ov", ...) {
    lav_deprecated("lavNames", times = 0L) #--> for now no warning
    sc <- sys.call()
    sc[[1L]] <- quote(lavaan::lavNames)
    eval(sc, parent.frame())
}

# standardize function names in lav_simulate_old.R / 9 December 2025
simulateData <- function(
                         model = NULL,
                         model.type = "sem",
                         meanstructure = FALSE,
                         int.ov.free = TRUE,
                         int.lv.free = FALSE,
                         marker.int.zero = FALSE,
                         conditional.x = FALSE,
                         composites = TRUE,
                         fixed.x = FALSE,
                         orthogonal = FALSE,
                         std.lv = TRUE,
                         auto.fix.first = FALSE,
                         auto.fix.single = FALSE,
                         auto.var = TRUE,
                         auto.cov.lv.x = TRUE,
                         auto.cov.y = TRUE,
                         ...,
                         sample.nobs = 500L,
                         ov.var = NULL,
                         group.label = paste("G", 1:ngroups, sep = ""),
                         skewness = NULL,
                         kurtosis = NULL,
                         seed = NULL,
                         empirical = FALSE,
                         return.type = "data.frame",
                         return.fit = FALSE,
                         debug = FALSE,
                         standardized = FALSE) {
  lav_deprecated("lavSimulateData", times = 0L)   #--> for now no warning
  if (is.list(model)) {
    ngroups <- lav_partable_ngroups(model)
  } else {
    ngroups <- sample.nobs
  }
  sc <- sys.call()
  # call new function
  sc[[1L]] <- quote(lavaan::lavSimulateData)
  eval(sc, parent.frame())
}
# standardize function names in lav_bootstrap.R / 9 December 2025
bootstrapLavaan <- function(object,
                            R = 1000L,
                            type = "ordinary",
                            verbose = FALSE,
                            FUN = "coef",
                            keep.idx = FALSE,
                            parallel = c("no", "multicore", "snow"),
                            ncpus = max(1L, parallel::detectCores() - 2L),
                            cl = NULL,
                            iseed = NULL,
                            h0.rmsea = NULL,
                            ...) {
    lav_deprecated("lavBootstrap", times = 0L) #--> for now no warning
    sc <- sys.call()
    # call new function
    sc[[1L]] <- quote(lavaan::lavBootstrap)
    eval(sc, parent.frame())
}

# standardize exported functions  / 13 December 2025
inspectSampleCov <- function(model, data, ...) {
    lav_deprecated("lavInspectSampleCov") #--> for now no warning
    sc <- sys.call()
    sc[[1L]] <- quote(lavaan::lavInspectSampleCov)
    eval(sc, parent.frame())
}                                                                  # nolint end

# parameterestimates <- function(object,
#                                se = TRUE, zstat = TRUE, pvalue = TRUE,
#                                ci = TRUE, standardized = FALSE,
#                                fmi = FALSE, plabel = FALSE,
#                                level = 0.95, boot.ci.type = "perc",
#                                cov.std = TRUE, fmi.options = list(),
#                                rsquare = FALSE,
#                                remove.system.eq = TRUE, remove.eq = TRUE,
#                                remove.ineq = TRUE, remove.def = FALSE,
#                                remove.nonfree = FALSE, remove.step1 = TRUE,
#                                remove.unused = FALSE, add.attributes = FALSE,
#                                output = "data.frame", header = FALSE) {
#   lav_deprecated("lavParameterEstimates", times = 1L) #--> for now no warning
#   sc <- sys.call()
#   sc[[1L]] <- quote(lavaan::lavParameterEstimates)
#   eval(sc, parent.frame())
# }
parameterestimates <- parameterEstimates # alias

# for tidySEM in 0.6-21 only
# vnames <- lav_partable_vnames

# James-Stein estimator
#
# Burghgraeve, E., De Neve, J., & Rosseel, Y. (2021). Estimating structural
# equation models using James-Stein type shrinkage estimators. Psychometrika,
# 86(1), 96-130.
#
# YR 08 Feb 2023: - first version in lavaan, cfa only (for now)

lav_cfa_jamesstein <- function(S,
                               Y = NULL, # raw data
                               marker.idx = NULL,
                               lambda.nonzero.idx = NULL,
                               theta = NULL, # vector!
                               theta.bounds = TRUE,
                               aggregated = FALSE) { # aggregated?
  # dimensions
  nvar <- ncol(S)
  nfac <- length(marker.idx)
  stopifnot(length(theta) == nvar)
  N <- nrow(Y)
  stopifnot(ncol(Y) == nvar)

  # overview of lambda structure
  B <- LAMBDA <- B.nomarker <- matrix(0, nvar, nfac)
  lambda.marker.idx <- (seq_len(nfac) - 1L) * nvar + marker.idx
  B[lambda.marker.idx] <- LAMBDA[lambda.marker.idx] <- 1L
  B[lambda.nonzero.idx] <- B.nomarker[lambda.nonzero.idx] <- 1L

  # Nu
  NU <- numeric(nvar)

  # do we first 'clip' the theta values so they are within standard bounds?
  # (Question: do we need the 0.01 and 0.99 multipliers?)
  diagS <- diag(S)
  if (theta.bounds) {
    # lower bound
    lower.bound <- diagS * 0 # * 0.01
    too.small.idx <- which(theta < lower.bound)
    if (length(too.small.idx) > 0L) {
      theta[too.small.idx] <- lower.bound[too.small.idx]
    }

    # upper bound
    upper.bound <- diagS * 1 # * 0.99
    too.large.idx <- which(theta > upper.bound)
    if (length(too.large.idx) > 0L) {
      theta[too.large.idx] <- upper.bound[too.large.idx]
    }
  }

  # compute conditional expectation conditional on the scaling indicator
  E.JS1 <- lav_cfa_jamesstein_ce(
    Y = Y, marker.idx = marker.idx,
    resvars.markers = theta[marker.idx]
  )

  # compute LAMBDA
  for (f in seq_len(nfac)) {
    nomarker.idx <- which(B.nomarker[, f] == 1)
    Y.nomarker.f <- Y[, nomarker.idx, drop = FALSE]

    # regress no.marker.idx data on E(\eta|Y)
    fit <- lm(Y.nomarker.f ~ E.JS1[, f, drop = FALSE])

    # extract 'lambda' values
    LAMBDA[nomarker.idx, f] <- drop(coef(fit)[-1, ])

    # (optional) extract means
    # NU[nomarker.idx] <- drop(coef(fit)[1,])

    if (aggregated) {
      # local copy of 'scaling' LAMBDA
      LAMBDA.scaling <- LAMBDA

      J <- length(nomarker.idx)
      for (j in seq_len(J)) {
        # data without this indicator
        j.idx <- nomarker.idx[j]
        no.j.idx <- c(marker.idx[f], nomarker.idx[-j])
        Y.agg <- Y[, no.j.idx, drop = FALSE]
        Y.j <- Y[, j.idx, drop = FALSE]

        # retrieve estimated values scaling JS
        lambda.JS.scaling <- LAMBDA.scaling[no.j.idx, f, drop = FALSE]

        # optimize the weights
        starting.weights <- rep(1 / J, times = J)
        w <- optim(
          par = starting.weights,
          fn = lav_cfa_jamesstein_rel,
          data = Y.agg,
          resvars = theta[no.j.idx]
        )$par

        # make sure the weights sum up to 1
        w.optim <- w / sum(w)

        # compute aggregated indicator using the optimal weights
        y_agg <- t(t(w.optim) %*% t(Y.agg))

        # compute error variance of the aggregated indicator
        var_eps_agg <- drop(t(w.optim) %*%
          diag(theta[no.j.idx], nrow = length(no.j.idx)) %*% w.optim)

        # compute conditional expectation using aggregated indicator
        tmp <- lav_cfa_jamesstein_ce(
          Y = y_agg, marker.idx = 1L,
          resvars.markers = var_eps_agg
        )
        CE_agg <- tmp / drop(w.optim %*% lambda.JS.scaling)

        # compute factor loading
        fit <- lm(Y.j ~ CE_agg)
        LAMBDA[j.idx, f] <- drop(coef(fit)[-1])

        # (optional) extract means
        # NU[j.idx] <- drop(coef(fit)[1,])
      } # j
    } # aggregate
  } # f

  out <- list(lambda = LAMBDA, nu = NU)
}

# internal function to be used inside lav_optim_noniter
# return 'x', the estimated vector of free parameters
lav_cfa_jamesstein_internal <- function(lavobject = NULL, # convenience
                                        # internal slot
                                        lavmodel = NULL,
                                        lavsamplestats = NULL,
                                        lavpartable = NULL,
                                        lavdata = NULL,
                                        lavoptions = NULL,
                                        theta.bounds = TRUE) {
  lavpta <- NULL
  if (!is.null(lavobject)) {
    stopifnot(inherits(lavobject, "lavaan"))

    # extract slots
    lavmodel <- lavobject@Model
    lavsamplestats <- lavobject@SampleStats
    lavpartable <- lav_partable_set_cache(lavobject@ParTable, lavobject@pta)
    lavpta <- lavobject@pta
    lavdata <- lavobject@Data
    lavoptions <- lavobject@Options
  }
  if (is.null(lavpta)) {
    lavpta <- lav_partable_attributes(lavpartable)
    lavpartable <- lav_partable_set_cache(lavpartable, lavpta)
  }

  # no structural part!
  if (any(lavpartable$op == "~")) {
    lav_msg_stop(gettext(
      "JS(A) estimator only available for CFA models (for now)"))
  }
  # no BETA matrix! (i.e., no higher-order factors)
  if (!is.null(lavmodel@GLIST$beta)) {
    lav_msg_stop(gettext(
      "JS(A) estimator not available for models that require a BETA matrix"))
  }
  # no std.lv = TRUE for now
  if (lavoptions$std.lv) {
    lav_msg_stop(gettext("S(A) estimator not available if std.lv = TRUE"))
  }

  nblocks <- lav_partable_nblocks(lavpartable)
  stopifnot(nblocks == 1L) # for now
  b <- 1L
  sample.cov <- lavsamplestats@cov[[b]]
  nvar <- nrow(sample.cov)
  lv.names <- lavpta$vnames$lv.regular[[b]]
  nfac <- length(lv.names)
  marker.idx <- lavpta$vidx$lv.marker[[b]]
  lambda.idx <- which(names(lavmodel@GLIST) == "lambda")
  lambda.nonzero.idx <- lavmodel@m.free.idx[[lambda.idx]]
  # only diagonal THETA for now...
  theta.idx <- which(names(lavmodel@GLIST) == "theta") # usually '2'
  m.theta <- lavmodel@m.free.idx[[theta.idx]]
  nondiag.idx <- m.theta[!m.theta %in% lav_matrix_diag_idx(nvar)]
  if (length(nondiag.idx) > 0L) {
    lav_msg_warn(gettext(
      "this implementation of JS/JSA does not handle correlated residuals yet!"
      ))
  }


  # 1. obtain estimate for (diagonal elements of) THETA
  #    for now we use Spearman per factor
  B <- matrix(0, nvar, nfac)
  lambda.marker.idx <- (seq_len(nfac) - 1L) * nvar + marker.idx
  B[lambda.marker.idx] <- 1L
  B[lambda.nonzero.idx] <- 1L
  theta <- numeric(nvar)
  for (f in seq_len(nfac)) {
    ov.idx <- which(B[, f] == 1L)
    S.fac <- sample.cov[ov.idx, ov.idx, drop = FALSE]
    theta[ov.idx] <- lav_cfa_theta_spearman(S.fac, bounds = "wide")
  }
  THETA <- diag(theta, nrow = nvar)

  # 2. run James-Stein algorithm
  Y <- lavdata@X[[1]] # raw data
  aggregated <- FALSE
  if (lavoptions$estimator == "JSA") {
    aggregated <- TRUE
  }
  out <- lav_cfa_jamesstein(
    S = sample.cov, Y = Y, marker.idx = marker.idx,
    lambda.nonzero.idx = lambda.nonzero.idx,
    theta = theta,
    # experimental
    theta.bounds = theta.bounds,
    #
    aggregated = aggregated
  )
  LAMBDA <- out$lambda

  # 3. PSI
  PSI <- lav_cfa_lambdatheta2psi(
    lambda = LAMBDA, theta = theta,
    S = sample.cov, mapping = "ML"
  )

  # store matrices in lavmodel@GLIST
  lavmodel@GLIST$lambda <- LAMBDA
  lavmodel@GLIST$theta <- THETA
  lavmodel@GLIST$psi <- PSI

  # extract free parameters only
  x <- lav_model_get_parameters(lavmodel)

  # apply bounds (if any)
  if (!is.null(lavpartable$lower)) {
    lower.x <- lavpartable$lower[lavpartable$free > 0]
    too.small.idx <- which(x < lower.x)
    if (length(too.small.idx) > 0L) {
      x[too.small.idx] <- lower.x[too.small.idx]
    }
  }
  if (!is.null(lavpartable$upper)) {
    upper.x <- lavpartable$upper[lavpartable$free > 0]
    too.large.idx <- which(x > upper.x)
    if (length(too.large.idx) > 0L) {
      x[too.large.idx] <- upper.x[too.large.idx]
    }
  }

  x
}


# Conditional expectation (Section 2.1, eq. 10)
lav_cfa_jamesstein_ce <- function(Y = NULL,
                                  marker.idx = NULL,
                                  resvars.markers = NULL) {
  Y <- as.matrix(Y)

  # sample size
  N <- nrow(Y)
  N1 <- N - 1
  N3 <- N - 3

  # markers only
  Y.marker <- Y[, marker.idx, drop = FALSE]

  # means and variances
  MEAN <- colMeans(Y.marker, na.rm = TRUE)
  VAR <- apply(Y.marker, 2, var, na.rm = TRUE)

  # 1 - R per maker
  oneminR <- N3 * resvars.markers / (N1 * VAR)

  # R per marker
  R <- 1 - oneminR

  # create E(\eta | Y)
  E.eta.cond.Y <- t(t(Y.marker) * R + oneminR * MEAN)

  E.eta.cond.Y
}

# Reliability function used to obtain the weights (Section 4, Aggregation)
lav_cfa_jamesstein_rel <- function(w = NULL, data = NULL, resvars = NULL) {
  # construct weight vector
  w <- matrix(w, ncol = 1)

  # construct aggregated indicator: y_agg = t(w) %*% y_i
  y_agg <- t(t(w) %*% t(data))

  # calculate variance of aggregated indicator
  var_y_agg <- var(y_agg)

  # calculate error variance of the aggregated indicator
  var_eps_agg <- t(w) %*% diag(resvars) %*% w

  # reliability function to be maximized
  rel <- (var_y_agg - var_eps_agg) %*% solve(var_y_agg)

  # return value
  return(-rel)
}

# classic score test (= Lagrange Multiplier test)
#
# this function can run in two modes:
#
# MODE 1: 'add'
#   add new parameters that are currently not included in de model
#   (aka fixed to zero), but should be released
#
# MODE 2: 'release' (the default)
#   release existing "==" constraints
#
# - YR 8 Jan 2026: use ceq.JAC instead of con.jac (as we do not support
#                  inequality constraints anyway, and we do not want to
#                  release the EFA constraints)

lavTestScore <- function(object, add = NULL, release = NULL,
                         univariate = TRUE, cumulative = FALSE,
                         epc = FALSE, standardized = epc, cov.std = epc,
                         verbose = FALSE, warn = TRUE,
                         information = "expected") {
  # check object
  object <- lav_object_check_version(object)

  if (!missing(warn)) {
    current.warn <- lav_warn()
    if (lav_warn(warn))
      on.exit(lav_warn(current.warn))
  }
  if (!missing(verbose)) {
    current.verbose <- lav_verbose()
    if (lav_verbose(verbose))
      on.exit(lav_verbose(current.verbose), TRUE)
  }
  # check object
  stopifnot(inherits(object, "lavaan"))
  lavoptions <- object@Options

  if (object@optim$npar > 0L && !object@optim$converged) {
    lav_msg_stop(gettext("model did not converge"))
  }

  # check for inequality constraints
  PT <- object@ParTable
  if (any(PT$op == ">" | PT$op == "<")) {
    lav_msg_stop(gettext(
      "lavTestScore() does not handle inequality constraints (yet)"))
  }

  # check arguments
  if (cumulative) {
    univariate <- TRUE
  }


  # Mode 1: ADDING new parameters
  if (!is.null(add) && all(nchar(add) > 0L)) {
    # check release argument
    if (!is.null(release)) {
      lav_msg_stop(gettext(
        "`add' and `release' arguments cannot be used together."))
    }

    # extend model with extra set of parameters
    FIT <- lav_object_extended(object, add = add)

    score <- lavTech(FIT, "gradient.logl")
    Information <- lavTech(FIT, paste("information", information, sep = "."))

    npar <- object@Model@nx.free
    nadd <- FIT@Model@nx.free - npar

    # R
    R.model <- object@Model@ceq.JAC[, , drop = FALSE]
    if (nrow(R.model) > 0L) {
      R.model <- cbind(R.model, matrix(0, nrow(R.model), ncol = nadd))
      R.add <- cbind(matrix(0, nrow = nadd, ncol = npar), diag(nadd))
      R <- rbind(R.model, R.add)

      Z <- cbind(
        rbind(Information, R.model),
        rbind(t(R.model), matrix(0, nrow(R.model), nrow(R.model)))
      )
      Z.plus <- MASS::ginv(Z)
      J.inv <- Z.plus[1:nrow(Information), 1:nrow(Information)]

      r.idx <- seq_len(nadd) + nrow(R.model)
    } else {
      R <- cbind(matrix(0, nrow = nadd, ncol = npar), diag(nadd))
      J.inv <- MASS::ginv(Information)

      r.idx <- seq_len(nadd)
    }

    # lhs/rhs
    lhs <- lav_partable_labels(FIT@ParTable)[FIT@ParTable$user == 10L]
    op <- rep("==", nadd)
    rhs <- rep("0", nadd)
    Table <- data.frame(
      lhs = lhs, op = op, rhs = rhs,
      stringsAsFactors = FALSE
    )
    class(Table) <- c("lavaan.data.frame", "data.frame")
  } else {
    # MODE 2: releasing constraints

    R <- object@Model@ceq.JAC[, , drop = FALSE]
    if (nrow(R) == 0L) {
      lav_msg_stop(gettext("no equality constraints found in model."))
    }

    score <- lavTech(object, "gradient.logl")
    Information <- lavTech(
      object,
      paste("information", information, sep = ".")
    )
    J.inv <- MASS::ginv(Information) # FIXME: move into if(is.null(release))?
    #                 else written over with Z1.plus if(is.numeric(release))
    # R <- object@Model@con.jac[,]

    if (is.null(release)) {
      # ALL constraints
      r.idx <- seq_len(nrow(R))
    } else if (is.numeric(release)) {
      r.idx <- release
      if (max(r.idx) > nrow(R)) {
        lav_msg_stop(gettextf(
          "maximum constraint number (%1$s) is larger than number of
          constraints (%2$s)", max(r.idx), nrow(R)))
      }

      # neutralize the non-needed constraints
      R1 <- R[-r.idx, , drop = FALSE]
      Z1 <- cbind(
        rbind(Information, R1),
        rbind(t(R1), matrix(0, nrow(R1), nrow(R1)))
      )
      Z1.plus <- MASS::ginv(Z1)
      J.inv <- Z1.plus[1:nrow(Information), 1:nrow(Information)]
    } else if (is.character(release)) {
      lav_msg_stop(gettext("not implemented yet"))
    }

    # lhs/rhs
    eq.idx <- which(object@ParTable$op == "==")
    if (length(eq.idx) > 0L) {
      lhs <- object@ParTable$lhs[eq.idx][r.idx]
      op <- rep("==", length(r.idx))
      rhs <- object@ParTable$rhs[eq.idx][r.idx]
    }
    Table <- data.frame(
      lhs = lhs, op = op, rhs = rhs,
      stringsAsFactors = FALSE
    )
    class(Table) <- c("lavaan.data.frame", "data.frame")
  }

  if (object@Data@nlevels == 1L) {
    N <- object@SampleStats@ntotal
    if (lavoptions$mimic == "EQS") {
      N <- N - 1
    }
  } else {
    # total number of clusters (over groups)
    N <- 0
    for (g in 1:object@SampleStats@ngroups) {
      N <- N + object@Data@Lp[[g]]$nclusters[[2]]
    }
    # score <- score * (2 * object@SampleStats@ntotal) / N
    score <- score / 2 # -2 * LRT
  }

  if (lavoptions$se == "standard") {
    stat <- as.numeric(N * score %*% J.inv %*% score)
  } else {
    # generalized score test
    lav_msg_warn(gettext("se is not `standard'; not implemented yet;
                         falling back to ordinary score test"))

    # NOTE!!!
    # we can NOT use VCOV here, because it reflects the constraints,
    # and the whole point is to test for these constraints...

    stat <- as.numeric(N * score %*% J.inv %*% score)
  }

  # compute df, taking into account that some of the constraints may
  # be needed to identify the model (and hence Information is singular)
  # Information.plus <- Information + crossprod(R)
  # df <- qr(R[r.idx,,drop = FALSE])$rank +
  #          ( qr(Information)$rank - qr(Information.plus)$rank )
  df <- nrow(R[r.idx, , drop = FALSE])
  pvalue <- 1 - pchisq(stat, df = df)

  # total score test
  TEST <- data.frame(
    test = "score", X2 = stat, df = df, p.value = pvalue,
    stringsAsFactors = FALSE
  )
  class(TEST) <- c("lavaan.data.frame", "data.frame")
  attr(TEST, "header") <- "total score test:"

  OUT <- list(test = TEST)

  if (univariate) {
    TS <- numeric(nrow(R))
    EPC.uni <- numeric(nrow(R)) # ignored in release= mode
    for (r in r.idx) {
      R1 <- R[-r, , drop = FALSE]
      Z1 <- cbind(
        rbind(Information, R1),
        rbind(t(R1), matrix(0, nrow(R1), nrow(R1)))
      )
      Z1.plus <- MASS::ginv(Z1)
      Z1.plus1 <- Z1.plus[1:nrow(Information), 1:nrow(Information)]
      TS[r] <- as.numeric(N * t(score) %*% Z1.plus1 %*% score)
      if (epc && !is.null(add)) {
        # EPC.uni[r] <- -1 * utils::tail(as.numeric(score %*%  Z1.plus1),
        #                               n = nrow(R))[r]
        # to keep the 'sign' consistent with modindices(), which
        # uses epc = 'new - old'
        EPC.uni[r] <- +1 * utils::tail(as.numeric(score %*% Z1.plus1),
          n = nrow(R)
        )[r]
      }
    }

    Table2 <- Table
    Table2$X2 <- TS[r.idx]
    Table2$df <- rep(1, length(r.idx))
    Table2$p.value <- 1 - pchisq(Table2$X2, df = Table2$df)
    if (epc && !is.null(add)) {
      Table2$epc <- EPC.uni[r.idx]
    }
    attr(Table2, "header") <- "univariate score tests:"
    OUT$uni <- Table2
  }

  if (cumulative) {
    TS.order <- sort.int(TS, index.return = TRUE, decreasing = TRUE)$ix
    ROW.order <- sort.int(TS[r.idx], index.return = TRUE, decreasing = TRUE)$ix
    TS <- numeric(length(r.idx))
    for (r in 1:length(r.idx)) {
      rcumul.idx <- TS.order[1:r]

      R1 <- R[-rcumul.idx, , drop = FALSE]
      Z1 <- cbind(
        rbind(Information, R1),
        rbind(t(R1), matrix(0, nrow(R1), nrow(R1)))
      )
      Z1.plus <- MASS::ginv(Z1)
      Z1.plus1 <- Z1.plus[1:nrow(Information), 1:nrow(Information)]
      TS[r] <- as.numeric(N * t(score) %*% Z1.plus1 %*% score)
    }

    Table3 <- Table[ROW.order, ]
    Table3$X2 <- TS
    Table3$df <- seq_len(length(TS))
    Table3$p.value <- 1 - pchisq(Table3$X2, df = Table3$df)
    attr(Table3, "header") <- "cumulative score tests:"
    OUT$cumulative <- Table3
  }

  if (epc) {
    # EPC <- vector("list", length = length(r.idx))
    # for(i in 1:length(r.idx)) {
    #    r <- r.idx[i]
    #    R1 <- R[-r,,drop = FALSE]
    #    Z1 <- cbind( rbind(Information, R1),
    #                 rbind(t(R1), matrix(0,nrow(R1),nrow(R1))) )
    #    Z1.plus <- MASS::ginv(Z1)
    #    Z1.plus1 <- Z1.plus[ 1:nrow(Information), 1:nrow(Information) ]
    #    EPC[[i]] <- -1 * as.numeric(score %*%  Z1.plus1)
    # }
    #
    # OUT$EPC <- EPC

    # alltogether
    R1 <- R[-r.idx, , drop = FALSE]
    Z1 <- cbind(
      rbind(Information, R1),
      rbind(t(R1), matrix(0, nrow(R1), nrow(R1)))
    )
    Z1.plus <- MASS::ginv(Z1)
    Z1.plus1 <- Z1.plus[1:nrow(Information), 1:nrow(Information)]
    # EPC.all <- -1 * as.numeric(score %*%  Z1.plus1)
    # to keep the 'sign' consistent with modindices(), which
    # uses epc = 'new - old'
    EPC.all <- +1 * as.numeric(score %*% Z1.plus1)

    # create epc table for the 'free' parameters
    if (!is.null(add) && all(nchar(add) > 0L)) {
      LIST <- parTable(FIT)
    } else {
      ## release mode
      LIST <- parTable(object)
    }
    if (lav_partable_ngroups(LIST) == 1L) {
      LIST$group <- NULL
    }
    nonpar.idx <- which(LIST$op %in% c("==", ":=", "<", ">"))
    if (length(nonpar.idx) > 0L) {
      LIST <- LIST[-nonpar.idx, ]
    }

    LIST$est[LIST$free > 0 & LIST$user != 10] <- lav_object_inspect_coef(object, type = "free")
    LIST$est[LIST$user == 10L] <- 0
    LIST$epc <- rep(as.numeric(NA), length(LIST$lhs))
    LIST$epc[LIST$free > 0] <- EPC.all
    LIST$epv <- LIST$est + LIST$epc

    if (standardized) {
      EPC <- LIST$epc

      if (cov.std) {
        # replace epc values for variances by est values
        var.idx <- which(LIST$op == "~~" & LIST$lhs == LIST$rhs &
          LIST$exo == 0L)
        EPC[var.idx] <- LIST$est[var.idx]
      }

      # two problems:
      #   - EPC of variances can be negative, and that is
      #     perfectly legal
      #   - EPC (of variances) can be tiny (near-zero), and we should
      #     not divide by tiny variables
      small.idx <- which(LIST$op == "~~" &
        LIST$lhs == LIST$rhs &
        abs(EPC) < sqrt(.Machine$double.eps))
      if (length(small.idx) > 0L) {
        EPC[small.idx] <- as.numeric(NA)
      }

      # get the sign
      EPC.sign <- sign(LIST$epc)

      LIST$sepc.lv <- EPC.sign * lav_standardize_lv(object,
        partable = LIST,
        est = abs(EPC),
        cov.std = cov.std
      )
      if (length(small.idx) > 0L) {
        LIST$sepc.lv[small.idx] <- 0
      }
      LIST$sepc.all <- EPC.sign * lav_standardize_all(object,
        partable = LIST,
        est = abs(EPC),
        cov.std = cov.std
      )
      if (length(small.idx) > 0L) {
        LIST$sepc.all[small.idx] <- 0
      }
      LIST$sepc.nox <- EPC.sign * lav_standardize_all_nox(object,
        partable = LIST,
        est = abs(EPC),
        cov.std = cov.std
      )
      if (length(small.idx) > 0L) {
        LIST$sepc.nox[small.idx] <- 0
      }
    }

    LIST$free[LIST$user == 10L] <- 0
    LIST$user <- NULL
    # remove some more columns
    LIST$id <- LIST$ustart <- LIST$exo <- LIST$start <- LIST$se <- LIST$prior <- NULL
    if (lav_partable_nblocks(LIST) == 1L) {
      LIST$block <- NULL
      LIST$group <- NULL
      LIST$level <- NULL
    }

    attr(LIST, "header") <- "expected parameter changes (epc) and expected parameter values (epv):"

    OUT$epc <- LIST
  }

  OUT
}

# fitting function for standard ML
lav_model_objective_ml <- function(Sigma.hat = NULL, Mu.hat = NULL,
                         data.cov = NULL, data.mean = NULL,
                         data.cov.log.det = NULL,
                         meanstructure = FALSE) {
  # FIXME: WHAT IS THE BEST THING TO DO HERE??
  # CURRENTLY: return Inf  (at least for nlminb, this works well)
  if (!attr(Sigma.hat, "po")) {
    return(Inf)
  }


  Sigma.hat.inv <- attr(Sigma.hat, "inv")
  Sigma.hat.log.det <- attr(Sigma.hat, "log.det")
  nvar <- ncol(Sigma.hat)

  if (!meanstructure) {
    fx <- (Sigma.hat.log.det + sum(data.cov * Sigma.hat.inv) -
      data.cov.log.det - nvar)
  } else {
    W.tilde <- data.cov + tcrossprod(data.mean - Mu.hat)
    fx <- (Sigma.hat.log.det + sum(W.tilde * Sigma.hat.inv) -
      data.cov.log.det - nvar)
  }

  # no negative values
  if (is.finite(fx) && fx < 0.0) fx <- 0.0

  fx
}

# fitting function for standard ML
lav_model_objective_ml_res <- function(Sigma.hat = NULL, Mu.hat = NULL, PI = NULL,
                             res.cov = NULL, res.int = NULL, res.slopes = NULL,
                             res.cov.log.det = NULL,
                             cov.x = NULL, mean.x = NULL) {
  if (!attr(Sigma.hat, "po")) {
    return(Inf)
  }

  # augmented mean.x + cov.x matrix
  C3 <- rbind(
    c(1, mean.x),
    cbind(mean.x, cov.x + tcrossprod(mean.x))
  )

  Sigma.hat.inv <- attr(Sigma.hat, "inv")
  Sigma.hat.log.det <- attr(Sigma.hat, "log.det")
  nvar <- ncol(Sigma.hat)

  # sigma
  objective.sigma <- (Sigma.hat.log.det + sum(res.cov * Sigma.hat.inv) -
    res.cov.log.det - nvar)
  # beta
  OBS <- t(cbind(res.int, res.slopes))
  EST <- t(cbind(Mu.hat, PI))
  Diff <- OBS - EST
  objective.beta <- sum(Sigma.hat.inv * crossprod(Diff, C3) %*% Diff)

  fx <- objective.sigma + objective.beta

  # no negative values
  if (is.finite(fx) && fx < 0.0) fx <- 0.0

  fx
}


# fitting function for restricted ML
lav_model_objective_reml <- function(Sigma.hat = NULL, Mu.hat = NULL,
                           data.cov = NULL, data.mean = NULL,
                           data.cov.log.det = NULL,
                           meanstructure = FALSE,
                           group = 1L, lavmodel = NULL,
                           lavsamplestats = NULL, lavdata = NULL) {
  if (!attr(Sigma.hat, "po")) {
    return(Inf)
  }

  Sigma.hat.inv <- attr(Sigma.hat, "inv")
  Sigma.hat.log.det <- attr(Sigma.hat, "log.det")
  nvar <- ncol(Sigma.hat)

  if (!meanstructure) {
    fx <- (Sigma.hat.log.det + sum(data.cov * Sigma.hat.inv) -
      data.cov.log.det - nvar)
  } else {
    W.tilde <- data.cov + tcrossprod(data.mean - Mu.hat)
    fx <- (Sigma.hat.log.det + sum(W.tilde * Sigma.hat.inv) -
      data.cov.log.det - nvar)
  }

  lambda.idx <- which(names(lavmodel@GLIST) == "lambda")
  LAMBDA <- lavmodel@GLIST[[lambda.idx[group]]]
  data.cov.inv <- lavsamplestats@icov[[group]]
  reml.h0 <- log(det(t(LAMBDA) %*% Sigma.hat.inv %*% LAMBDA))
  reml.h1 <- log(det(t(LAMBDA) %*% data.cov.inv %*% LAMBDA))
  nobs <- lavsamplestats@nobs[[group]]

  # fx <- (Sigma.hat.log.det + tmp - data.cov.log.det - nvar) + 1/Ng * (reml.h0  - reml.h1)
  fx <- fx + (1 / nobs * (reml.h0 - reml.h1))

  # no negative values
  if (is.finite(fx) && fx < 0.0) fx <- 0.0

  fx
}

# 'classic' fitting function for GLS
# used again since 0.6-10 (we used the much slower lav_model_objective_wls before)
lav_model_objective_gls <- function(Sigma.hat = NULL, Mu.hat = NULL,
                          data.cov = NULL, data.cov.inv = NULL,
						  data.mean = NULL,
                          meanstructure = FALSE, correlation = FALSE) {
  tmp <- data.cov.inv %*% (data.cov - Sigma.hat)
  # tmp is not perfectly symmetric, so we use t(tmp) on the next line
  # to obtain the same value as lav_model_objective_wls
  fx <- 0.5 * sum(tmp * t(tmp))

  if (correlation) {
    # Bentler & Savalei (2010) eq 1.31
    DD <- as.matrix(diag(tmp))
    TT <- diag(nrow(data.cov)) + data.cov * data.cov.inv
    fx <- fx - drop(t(DD) %*% solve(TT) %*% DD)
  }

  if (meanstructure) {
    tmp2 <- sum(data.cov.inv * tcrossprod(data.mean - Mu.hat))
    fx <- fx + tmp2
  }

  # no negative values
  if (is.finite(fx) && fx < 0.0) fx <- 0.0

  fx
}

# general WLS estimator (Muthen, Appendix 4, eq 99 single group)
# full weight (WLS.V) matrix
lav_model_objective_wls <- function(WLS.est = NULL, WLS.obs = NULL, WLS.V = NULL) {
  # diff <- as.matrix(WLS.obs - WLS.est)
  # fx <- as.numeric( t(diff) %*% WLS.V %*% diff )

  # since 0.5-17, we use crossprod twice
  diff <- WLS.obs - WLS.est
  fx <- as.numeric(crossprod(crossprod(WLS.V, diff), diff))
  # todo alternative: using chol(WLS.V)

  # no negative values
  if (is.finite(fx) && fx < 0.0) fx <- 0.0

  fx
}

# diagonally weighted LS (DWLS)
lav_model_objective_dwls <- function(WLS.est = NULL, WLS.obs = NULL, WLS.VD = NULL) {
  diff <- WLS.obs - WLS.est
  fx <- sum(diff * diff * WLS.VD)

  # no negative values
  if (is.finite(fx) && fx < 0.0) fx <- 0.0

  fx
}

# Full Information ML estimator (FIML) handling the missing values
lav_model_objective_fiml <- function(Sigma.hat = NULL, Mu.hat = NULL, Yp = NULL,
                           h1 = NULL, N = NULL) {
  if (is.null(N)) {
    N <- sum(sapply(Yp, "[[", "freq"))
  }

  # Note: we ignore x.idx (if any)
  fx <- lav_mvnorm_missing_loglik_samplestats(
    Yp = Yp,
    Mu = Mu.hat, Sigma = Sigma.hat,
    log2pi = FALSE,
    minus.two = TRUE
  ) / N

  # ajust for h1
  if (!is.null(h1)) {
    fx <- fx - h1

    # no negative values
    if (is.finite(fx) && fx < 0.0) fx <- 0.0
  }

  fx
}

# pairwise maximum likelihood
# this is adapted from code written by Myrsini Katsikatsou
#
# some changes:
# - no distinction between x/y (ksi/eta)
# - 29/03/2016: adapt for exogenous covariates
# - 21/09/2016: added code for missing = doubly.robust (contributed by
#   Myrsini Katsikatsou)
# - HJ 18/10/2023: For sampling weights the lavcache$bifreq are weighted
lav_model_objective_pml <- function(Sigma.hat = NULL, # model-based var/cov/cor
                          Mu.hat = NULL, # model-based means
                          TH = NULL, # model-based thresholds + means
                          PI = NULL, # slopes
                          th.idx = NULL, # threshold idx per variable
                          num.idx = NULL, # which variables are numeric
                          X = NULL, # raw data
                          eXo = NULL, # eXo data
                          wt = NULL, # case weights
                          lavcache = NULL, # housekeeping stuff
                          missing = NULL) { # how to deal with missings?

  # YR 3 okt 2012
  # - the idea is to compute for each pair of variables, the model-based
  #   probability (or likelihood in mixed case) (that we observe the data
  #   for this pair under the model)
  # - if we have exogenous variables + conditional.x, do this for each case
  # - after taking logs, the sum over the cases gives the
  #   log probablity/likelihood for this pair
  # - the sum over all pairs gives the final PL based logl

  # first of all: check if all correlations are within [-1,1]
  # if not, return Inf; (at least with nlminb, this works well)

  # diagonal of Sigma.hat is not necessarily 1, even for categorical vars
  Sigma.hat2 <- Sigma.hat
  if (length(num.idx) > 0L) {
    diag(Sigma.hat2)[-num.idx] <- 1
  } else {
    diag(Sigma.hat2) <- 1
  }
  # all positive variances? (for continuous variables)
  if (any(diag(Sigma.hat2) < 0)) {
    OUT <- +Inf
    attr(OUT, "logl") <- as.numeric(NA)
    return(OUT)
  }
  Cor.hat <- cov2cor(Sigma.hat2) # to get correlations (rho!)
  cors <- lav_matrix_vech(Cor.hat, diagonal = FALSE)

  if (length(cors) > 0L && (any(abs(cors) > 1) ||
    any(is.na(cors)))) {
    # question: what is the best approach here??
    OUT <- +Inf
    attr(OUT, "logl") <- as.numeric(NA)
    return(OUT)
  }

  nvar <- nrow(Sigma.hat)
  if (is.null(eXo)) {
    nexo <- 0L
  } else {
    nexo <- NCOL(eXo)
  }
  pstar <- nvar * (nvar - 1) / 2
  ov.types <- rep("ordered", nvar)
  if (length(num.idx) > 0L) {
    ov.types[num.idx] <- "numeric"
  }


  ##### Three cases:
  ##### 1) all ordered, no exogenous (fast!)
  ##### 2) mixed ordered + continuous, no exogenous
  ##### 3) mixed ordered + continuous, exogenous (conditional.x = TRUE)




  ##### Case 1:
  #####  all ordered
  #####  no exogenous covariates
  #####
  if (all(ov.types == "ordered") && nexo == 0L) {
    # prepare for Myrsini's vectorization scheme
    long2 <- lav_pml_longvec_th_rho(
      no.x = nvar,
      all.thres = TH,
      index.var.of.thres = th.idx,
      rho.xixj = cors
    )
    # get expected probability per table, per pair
    pairwisePI <- lav_pml_expprob_vec(
      ind.vec = lavcache$long,
      th.rho.vec = long2
    )
    pairwisePI_orig <- pairwisePI # for doubly.robust

    # get frequency per table, per pair
    logl <- sum(lavcache$bifreq * log(pairwisePI))

    # >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    # FYI the bifreq are already weighted so this will work. Alternatively:
    if (!is.null(wt)) {
      logl <- sum(lavcache$sum_obs_weights_xixj_ab_vec * log(pairwisePI))
    }

    # more convenient fit function
    prop <- lavcache$bifreq / lavcache$nobs
    freq <- lavcache$bifreq
    if (!is.null(wt)) {
      prop <- lavcache$sum_obs_weights_xixj_ab_vec / sum(wt)
      freq <- lavcache$sum_obs_weights_xixj_ab_vec
    }

    # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

    # remove zero props # FIXME!!! or add 0.5???
    # zero.idx <- which(prop == 0.0)
    zero.idx <- which((prop == 0.0) | !is.finite(prop))
    if (length(zero.idx) > 0L) {
      freq <- freq[-zero.idx]
      prop <- prop[-zero.idx]
      pairwisePI <- pairwisePI[-zero.idx]
    }
    ## Fmin <- sum( prop*log(prop/pairwisePI) )
    Fmin <- sum(freq * log(prop / pairwisePI)) # to avoid 'N'

    if (missing == "available.cases" || missing == "doubly.robust") {
      uniPI <- lav_pml_th_uni_prob(TH = TH, th.idx = th.idx)

      # shortcuts
      unifreq <- lavcache$unifreq
      uninobs <- lavcache$uninobs
      uniweights <- lavcache$uniweights

      logl <- logl + sum(uniweights * log(uniPI))

      uniprop <- unifreq / uninobs

      # remove zero props
      # uni.zero.idx <- which(uniprop == 0.0)
      uni.zero.idx <- which((uniprop == 0.0) | !is.finite(uniprop))
      if (length(uni.zero.idx) > 0L) {
        uniprop <- uniprop[-uni.zero.idx]
        uniPI <- uniPI[-uni.zero.idx]
        uniweights <- uniweights[-uni.zero.idx]
      }

      Fmin <- Fmin + sum(uniweights * log(uniprop / uniPI))
    }

    if (missing == "doubly.robust") {
      # COMPUTE THE SUM OF THE EXPECTED BIVARIATE CONDITIONAL LIKELIHOODS
      # SUM_{i,j} [ E_{Yi,Yj|y^o}(lnf(Yi,Yj))) ]

      # First compute the terms of the summand. Since the cells of
      # pairwiseProbGivObs are zero for the pairs of variables that at least
      # one of the variables is observed (hence not contributing to the summand)
      # there is no need to construct an index vector for summing appropriately
      # within each individual.
      log_pairwisePI_orig <- log(pairwisePI_orig)
      pairwiseProbGivObs <- lavcache$pairwiseProbGivObs
      tmp_prod <- t(t(pairwiseProbGivObs) * log_pairwisePI_orig)

      SumElnfijCasewise <- apply(tmp_prod, 1, sum)
      SumElnfij <- sum(SumElnfijCasewise)
      logl <- logl + SumElnfij
      Fmin <- Fmin - SumElnfij

      # COMPUTE THE THE SUM OF THE EXPECTED UNIVARIATE CONDITIONAL LIKELIHOODS
      # SUM_{i,j} [ E_{Yj|y^o}(lnf(Yj|yi))) ]

      # First compute the model-implied conditional univariate probabilities
      # p(y_i=a|y_j=b). Let ModProbY1Gy2 be the vector of these
      # probabilities. The order the probabilities
      # are listed in the vector ModProbY1Gy2 is as follows:
      # y1|y2, y1|y3, ..., y1|yp, y2|y1, y2|y3, ..., y2|yp,
      # ..., yp|y1, yp|y2, ..., yp|y(p-1). Within each pair of variables the
      # index "a" which represents the response category of variable yi runs faster than
      # "b" which represents the response category of the given variable yj.
      # The computation of these probabilities are based on the model-implied
      # bivariate probabilities p(y_i=a,y_j=b). To do the appropriate summations
      # and divisions we need some index vectors to keep track of the index i, j,
      # a, and b, as well as the pair index. These index vectors should be
      # computed once and stored in lavcache. About where in the lavaan code
      # we will add the computations and how they will be done please see the
      # file "new objects in lavcache for DR-PL.r"

      idx.pairs <- lavcache$idx.pairs
      idx.cat.y2.split <- lavcache$idx.cat.y2.split
      idx.cat.y1.split <- lavcache$idx.cat.y1.split
      idx.Y1 <- lavcache$idx.Y1
      idx.Gy2 <- lavcache$idx.Gy2
      idx.cat.Y1 <- lavcache$idx.cat.Y1
      idx.cat.Gy2 <- lavcache$idx.cat.Gy2
      id.uniPrGivObs <- lavcache$id.uniPrGivObs
      # the latter keeps track which variable each column of the matrix
      # univariateProbGivObs refers to

      # For the function lav_pml_bivprob_unicondprob see the .r file
      # with the same name.
      ModProbY1Gy2 <- lav_pml_bivprob_unicondprob(
        bivProb = pairwisePI_orig,
        nvar = nvar,
        idx.pairs = idx.pairs,
        idx.Y1 = idx.Y1,
        idx.Gy2 = idx.Gy2,
        idx.cat.y1.split = idx.cat.y1.split,
        idx.cat.y2.split = idx.cat.y2.split
      )

      log_ModProbY1Gy2 <- log(ModProbY1Gy2)

      # Let univariateProbGivObs be the matrix of the conditional univariate
      # probabilities Pr(y_i=a|y^o) that has been computed in advance and are
      # fed to the DR-PL function. The rows represent different individuals,
      # i.e. nrow=nobs, and the columns different probabilities. The columns
      # are listed as follows: a runs faster than i.

      # Note that the number of columns of univariateProbGivObs is not the
      # same with the length(log_ModProbY1Gy2), actually
      # ncol(univariateProbGivObs) < length(log_ModProbY1Gy2).
      # For this we use the following commands in order to multiply correctly.

      # Compute for each case the product  Pr(y_i=a|y^o) * log[ p(y_i=a|y_j=b) ]
      # i.e. univariateProbGivObs * log_ModProbY1Gy2
      univariateProbGivObs <- lavcache$univariateProbGivObs
      nobs <- nrow(X)
      uniweights.casewise <- lavcache$uniweights.casewise
      id.cases.with.missing <- which(uniweights.casewise > 0)
      no.cases.with.missing <- length(id.cases.with.missing)
      no.obs.casewise <- nvar - uniweights.casewise
      idx.missing.var <- apply(X, 1, function(x) {
        which(is.na(x))
      })
      idx.observed.var <- lapply(idx.missing.var, function(x) {
        c(1:nvar)[-x]
      })
      idx.cat.observed.var <- sapply(1:nobs, function(i) {
        X[i, idx.observed.var[[i]]]
      })
      ElnyiGivyjbCasewise <- sapply(1:no.cases.with.missing, function(i) {
        tmp.id.case <- id.cases.with.missing[i]
        tmp.no.mis <- uniweights.casewise[tmp.id.case]
        tmp.idx.mis <- idx.missing.var[[tmp.id.case]]
        tmp.idx.obs <- idx.observed.var[[tmp.id.case]]
        tmp.no.obs <- no.obs.casewise[tmp.id.case]
        tmp.idx.cat.obs <- idx.cat.observed.var[[tmp.id.case]]
        tmp.uniProbGivObs.i <- univariateProbGivObs[tmp.id.case, ]
        sapply(1:tmp.no.mis, function(k) {
          tmp.idx.mis.var <- tmp.idx.mis[k]
          tmp.uniProbGivObs.ik <-
            tmp.uniProbGivObs.i[id.uniPrGivObs == tmp.idx.mis.var]
          tmp.log_ModProbY1Gy2 <- sapply(1:tmp.no.obs, function(z) {
            log_ModProbY1Gy2[idx.Y1 == tmp.idx.mis.var &
              idx.Gy2 == tmp.idx.obs[z] &
              idx.cat.Gy2 == tmp.idx.cat.obs[z]]
          })
          sum(tmp.log_ModProbY1Gy2 * tmp.uniProbGivObs.ik)
        })
      })
      ElnyiGivyjb <- sum(unlist(ElnyiGivyjbCasewise))
      logl <- logl + ElnyiGivyjb
      # for the Fmin function
      Fmin <- Fmin - ElnyiGivyjb
    } # end of if (missing =="doubly.robust")


    ##### Case 2:
    #####  mixed ordered + numeric
    #####  no exogenous covariates
    #####
  } else if (nexo == 0L) {
    # mixed ordered/numeric variables, but no exogenous covariates
    # - no need to compute 'casewise' (log)likelihoods

    PSTAR <- matrix(0, nvar, nvar) # utility matrix, to get indices
    PSTAR[lav_matrix_vech_idx(nvar, diagonal = FALSE)] <- 1:pstar
    N <- NROW(X)

    logLikPair <- numeric(pstar) # logl per pair (summed over cases)
    for (j in seq_len(nvar - 1L)) {
      for (i in (j + 1L):nvar) {
        pstar.idx <- PSTAR[i, j]
        if (ov.types[i] == "numeric" &&
          ov.types[j] == "numeric") {
          logLIK <- lav_mvnorm_loglik_data(
            Y = X[, c(i, j)], wt = wt, Mu = Mu.hat[c(i, j)],
            Sigma = Sigma.hat[c(i, j), c(i, j)], casewise = TRUE
          )
          logLikPair[pstar.idx] <- sum(logLIK, na.rm = TRUE)
        } else if (ov.types[i] == "numeric" &&
          ov.types[j] == "ordered") {
          # polyserial correlation
          logLIK <- lav_bvmix_lik(
            Y1 = X[, i], Y2 = X[, j],
            wt = wt,
            evar.y1 = Sigma.hat[i, i],
            beta.y1 = Mu.hat[i],
            th.y2 = TH[th.idx == j],
            rho = Cor.hat[i, j], .log = TRUE
          )
          logLikPair[pstar.idx] <- sum(logLIK, na.rm = TRUE)
        } else if (ov.types[j] == "numeric" &&
          ov.types[i] == "ordered") {
          # polyserial correlation
          logLIK <- lav_bvmix_lik(
            Y1 = X[, j], Y2 = X[, i],
            wt = wt,
            evar.y1 = Sigma.hat[j, j],
            beta.y1 = Mu.hat[j],
            th.y2 = TH[th.idx == i],
            rho = Cor.hat[i, j], .log = TRUE
          )
          logLikPair[pstar.idx] <- sum(logLIK, na.rm = TRUE)
        } else if (ov.types[i] == "ordered" &&
          ov.types[j] == "ordered") {
          # polychoric correlation
          pairwisePI <- lav_bvord_noexo_pi(
            rho = Cor.hat[i, j],
            th.y1 = TH[th.idx == i],
            th.y2 = TH[th.idx == j]
          )
          # avoid zeroes
          pairwisePI[pairwisePI < .Machine$double.eps] <-
            .Machine$double.eps
          # note: missing values are just not counted
          FREQ <- lav_bvord_freq(X[, i], X[, j], wt = wt)
          logLikPair[pstar.idx] <- sum(FREQ * log(pairwisePI))
        }
      }
    } # all pairs

    na.idx <- which(is.na(logLikPair))
    if (length(na.idx) > 0L) {
      lav_msg_warn(gettext("some pairs produces NA values for logl:"),
        lav_msg_view(round(logLikPair, 3), "none")
      )
    }

    # sum over pairs
    logl <- sum(logLikPair)

    # Fmin
    Fmin <- (-1) * logl


    ##### Case 3:
    #####  mixed ordered + numeric
    #####  exogenous covariates
    #####  (conditional.x = TRUE)
  } else {
    LIK <- matrix(0, nrow(X), pstar) # likelihood per case, per pair
    PSTAR <- matrix(0, nvar, nvar) # utility matrix, to get indices
    PSTAR[lav_matrix_vech_idx(nvar, diagonal = FALSE)] <- 1:pstar
    N <- NROW(X)

    for (j in seq_len(nvar - 1L)) {
      for (i in (j + 1L):nvar) {
        pstar.idx <- PSTAR[i, j]
        # cat("pstar.idx =", pstar.idx, "i = ", i, " j = ", j, "\n")
        if (ov.types[i] == "numeric" &&
            ov.types[j] == "numeric") {
          # ordinary pearson correlation
          LIK[, pstar.idx] <-
            lav_bvreg_lik(
              Y1 = X[, i], Y2 = X[, j], eXo = eXo,
              wt = wt,
              evar.y1 = Sigma.hat[i, i],
              beta.y1 = c(Mu.hat[i], PI[i, ]),
              evar.y2 = Sigma.hat[j, j],
              beta.y2 = c(Mu.hat[j], PI[j, ]),
              rho = Cor.hat[i, j]
            )
        } else if (ov.types[i] == "numeric" &&
                   ov.types[j] == "ordered") {
          # polyserial correlation
          ### FIXME: th.y2 should go into ps_lik!!!
          LIK[, pstar.idx] <-
            lav_bvmix_lik(
              Y1 = X[, i], Y2 = X[, j], eXo = eXo,
              wt = wt,
              evar.y1 = Sigma.hat[i, i],
              beta.y1 = c(Mu.hat[i], PI[i, ]),
              th.y2 = TH[th.idx == j],
              sl.y2 = PI[j, ],
              rho = Cor.hat[i, j]
            )
        } else if (ov.types[j] == "numeric" &&
                   ov.types[i] == "ordered") {
          # polyserial correlation
          ### FIXME: th.y1 should go into ps_lik!!!
          LIK[, pstar.idx] <-
            lav_bvmix_lik(
              Y1 = X[, j], Y2 = X[, i], eXo = eXo,
              wt = wt,
              evar.y1 = Sigma.hat[j, j],
              beta.y1 = c(Mu.hat[j], PI[j, ]),
              th.y2 = TH[th.idx == i],
              sl.y2 = PI[i, ],
              rho = Cor.hat[i, j]
            )
        } else if (ov.types[i] == "ordered" &&
                   ov.types[j] == "ordered") {
          LIK[, pstar.idx] <-
            lav_pml_bi_lik_x(
              Y1 = X[, i],
              Y2 = X[, j],
              Rho = Sigma.hat[i, j],
              th.y1 = TH[th.idx == i],
              th.y2 = TH[th.idx == j],
              eXo = eXo,
              PI.y1 = PI[i, ],
              PI.y2 = PI[j, ],
              missing.ind = missing
            )
        }
      }
    } # all pairs

    # check for zero likelihoods/probabilities
    # FIXME: or should we replace them with a tiny number?
    if (any(LIK == 0.0, na.rm = TRUE)) {
      OUT <- +Inf
      attr(OUT, "logl") <- as.numeric(NA)
      return(OUT)
    }

    # loglikelihood
    LogLIK.cases <- log(LIK)

    # sum over cases
    LogLIK.pairs <- colSums(LogLIK.cases, na.rm = TRUE)

    # sum over pairs
    logl <- logl_pairs <- sum(LogLIK.pairs)

    if (missing == "available.cases" && all(ov.types == "ordered") &&
      nexo != 0L) {
      uni_LIK <- matrix(0, nrow(X), ncol(X))
      for (i in seq_len(nvar)) {
        uni_LIK[, i] <- lav_pml_uni_lik(
          Y1 = X[, i],
          th.y1 = TH[th.idx == i],
          eXo = eXo,
          PI.y1 = PI[i, ]
        )
      }

      if (any(uni_LIK == 0.0, na.rm = TRUE)) {
        OUT <- +Inf
        attr(OUT, "logl") <- as.numeric(NA)
        return(OUT)
      }

      uni_logLIK_cases <- log(uni_LIK) * lavcache$uniweights.casewise

      # sum over cases
      uni_logLIK_varwise <- colSums(uni_logLIK_cases)

      # sum over variables
      uni_logLIK <- sum(uni_logLIK_varwise)

      # add with the pairwise part of LogLik
      logl <- logl_pairs + uni_logLIK
    }

    # we minimise
    Fmin <- (-1) * logl
  }


  # here, we should have two quantities: logl and Fmin

  # function value as returned to the minimizer
  fx <- Fmin

  # attach 'loglikelihood'
  attr(fx, "logl") <- logl

  fx
}

# full information maximum likelihood
# underlying multivariate normal approach (see Joreskog & Moustaki, 2001)
#
lav_model_objective_fml <- function(Sigma.hat = NULL, # model-based var/cov/cor
                          TH = NULL, # model-based thresholds + means
                          th.idx = NULL, # threshold idx per variable
                          num.idx = NULL, # which variables are numeric
                          X = NULL, # raw data
                          lavcache = NULL) { # patterns

  # YR 27 aug 2013
  # just for fun, and to compare with PML for small models

  # first of all: check if all correlations are within [-1,1]
  # if not, return Inf; (at least with nlminb, this works well)
  cors <- Sigma.hat[lower.tri(Sigma.hat)]

  if (any(abs(cors) > 1)) {
    return(+Inf)
  }

  nvar <- nrow(Sigma.hat)
  pstar <- nvar * (nvar - 1) / 2
  ov.types <- rep("ordered", nvar)
  if (length(num.idx) > 0L) ov.types[num.idx] <- "numeric"
  MEAN <- rep(0, nvar)

  # shortcut for all ordered - per pattern
  if (all(ov.types == "ordered")) {
    PAT <- lavcache$pat
    npatterns <- nrow(PAT)
    freq <- as.numeric(rownames(PAT))
    PI <- numeric(npatterns)
    TH.VAR <- lapply(1:nvar, function(x) c(-Inf, TH[th.idx == x], +Inf))
    # FIXME!!! ok to set diagonal to 1.0?
    diag(Sigma.hat) <- 1.0
    for (r in 1:npatterns) {
      # compute probability for each pattern
      lower <- sapply(1:nvar, function(x) TH.VAR[[x]][PAT[r, x]])
      upper <- sapply(1:nvar, function(x) TH.VAR[[x]][PAT[r, x] + 1L])


      # how accurate must we be here???
      PI[r] <- sadmvn(lower, upper,
        mean = MEAN, varcov = Sigma.hat,
        maxpts = 10000 * nvar, abseps = 1e-07
      )
    }
    # sum (log)likelihood over all patterns
    # LogLik <- sum(log(PI) * freq)

    # more convenient fit function
    prop <- freq / sum(freq)
    # remove zero props # FIXME!!! or add 0.5???
    zero.idx <- which(prop == 0.0)
    if (length(zero.idx) > 0L) {
      prop <- prop[-zero.idx]
      PI <- PI[-zero.idx]
    }
    Fmin <- sum(prop * log(prop / PI))
  } else { # case-wise
    PI <- numeric(nobs)
    for (i in 1:nobs) {
      # compute probability for each case
      PI[i] <- lav_msg_stop(gettext("not implemented"))
    }
    # sum (log)likelihood over all observations
    LogLik <- sum(log(PI))
    lav_msg_stop(gettext("not implemented"))
  }

  # function value as returned to the minimizer
  # fx <- -1 * LogLik
  fx <- Fmin

  fx
}

lav_model_objective_mml <- function(lavmodel = NULL,
                          THETA = NULL,
                          TH = NULL,
                          GLIST = NULL,
                          group = 1L,
                          lavdata = NULL,
                          sample.mean = NULL,
                          sample.mean.x = NULL,
                          lavcache = NULL) {
  # compute case-wise likelihoods
  lik <- lav_model_lik_mml(
    lavmodel = lavmodel, THETA = THETA, TH = TH,
    GLIST = GLIST, group = group, lavdata = lavdata,
    sample.mean = sample.mean, sample.mean.x = sample.mean.x,
    lavcache = lavcache
  )

  # log + sum over observations
  logl <- sum(log(lik))

  # function value as returned to the minimizer
  fx <- -logl

  fx
}

lav_model_objective_2l <- function(lavmodel = NULL,
                         GLIST = NULL,
                         Y1 = NULL, # only for missing
                         Lp = NULL,
                         Mp = NULL,
                         lavsamplestats = NULL,
                         group = 1L) {
  # compute model-implied statistics for all blocks
  implied <- lav_model_implied(lavmodel, GLIST = GLIST)

  # here, we assume only 2!!! levels, at [[1]] and [[2]]
  if (lavmodel@conditional.x) {
    Res.Sigma.W <- implied$res.cov[[   (group - 1) * 2 + 1]]
    Res.Int.W   <- implied$res.int[[   (group - 1) * 2 + 1]]
    Res.Pi.W    <- implied$res.slopes[[(group - 1) * 2 + 1]]

    Res.Sigma.B <- implied$res.cov[[   (group - 1) * 2 + 2]]
    Res.Int.B   <- implied$res.int[[   (group - 1) * 2 + 2]]
    Res.Pi.B    <- implied$res.slopes[[(group - 1) * 2 + 2]]
  } else {
    Sigma.W <- implied$cov[[( group - 1) * 2 + 1]]
    Mu.W    <- implied$mean[[(group - 1) * 2 + 1]]
    Sigma.B <- implied$cov[[ (group - 1) * 2 + 2]]
    Mu.B    <- implied$mean[[(group - 1) * 2 + 2]]
  }

  if (lavsamplestats@missing.flag) {
    if (lavmodel@conditional.x) {
      lav_msg_stop(gettext("multilevel + conditional.x is not ready yet for
                           fiml; rerun with conditional.x = FALSE"))
    }
    # SIGMA.B <- Sigma.B[Lp$both.idx[[2]], Lp$both.idx[[2]], drop = FALSE]
    # if(any(diag(SIGMA.B) < 0)) {
    #    return(+Inf)
    # }
    # COR.B <- cov2cor(SIGMA.B)
    # if(any(abs(lav_matrix_vech(COR.B, diagonal = FALSE)) > 1)) {
    #   return(+Inf)
    # }

    Y2 <- lavsamplestats@YLp[[group]][[2]]$Y2
    Yp <- lavsamplestats@missing[[group]]
    loglik <- lav_mvnorm_cluster_missing_loglik_samplestats_2l(
      Y1 = Y1,
      Y2 = Y2, Lp = Lp, Mp = Mp,
      Mu.W = Mu.W, Sigma.W = Sigma.W,
      Mu.B = Mu.B, Sigma.B = Sigma.B,
      log2pi = FALSE, minus.two = TRUE
    )
  } else {
    YLp <- lavsamplestats@YLp[[group]]
    if (lavmodel@conditional.x) {
      loglik <- lav_mvreg_cluster_loglik_samplestats_2l(
        YLp = YLp, Lp = Lp,
        Res.Sigma.W = Res.Sigma.W,
        Res.Int.W = Res.Int.W, Res.Pi.W = Res.Pi.W,
        Res.Sigma.B = Res.Sigma.B,
        Res.Int.B = Res.Int.B, Res.Pi.B = Res.Pi.B,
        log2pi = FALSE, minus.two = TRUE
      )
    } else {
      loglik <- lav_mvnorm_cluster_loglik_samplestats_2l(
        YLp = YLp, Lp = Lp,
        Mu.W = Mu.W, Sigma.W = Sigma.W,
        Mu.B = Mu.B, Sigma.B = Sigma.B,
        log2pi = FALSE, minus.two = TRUE
      )
    }
  }

  # minimize (we already did -2*)
  objective <- 1 * loglik

  # divide by (N*2)
  objective <- objective / (lavsamplestats@ntotal * 2)

  # should be strictly positive
  # if(objective < 0) {
  #   objective <- +Inf
  # }

  objective
}

# residual diagnostics

# two types:
# 1) residuals for summary statistics
# 2) case-wise residuals

# this (new) version written around Aug/Sept 2018 for 0.6-3
# - based on obsList (inspect_sampstat) and estList (inspect_implied)
# - pre-scaling for type = "cor.bollen" and type = "cor.bentler"
# - summary statistics: rmr, srmr, crmr, urmr, usrmr, ucrmr; standard errors,
#       confidence intervals (for u(cs)rmr),
#       z-statistics (exact test, close test), p-values
# - type = "normalized" is based on lav_model_h1_acov(), and should now work
#   for all estimators
# - type = "standardized" now uses the correct formula, and should work for
#   for all estimators
# - type = "standardized.mplus" uses the simplified Mplus/LISREL version,
#   often resulting in NAs due to negative var(resid) estimates
#   (this was "standardized" in lavaan < 0.6.3

# WARNING: only partial support for conditional.x = TRUE!!
# - in categorical case: we only compute summary statistics, using cor + th
#   (no var, slopes, ...)
# - twolevel not supported here; see lav_fit_srmr.R, where we convert to
#   the unconditional setting

# - change 0.6-6: we enforce observed.information = "h1" to ensure 'Q' is a
#                 projection matrix (see lav_residuals_acov)

# - change 0.6-13: fixed.x = TRUE is ignored (to conform with 'tradition')

setMethod(
  "residuals", "lavaan",
  function(object, type = "raw", labels = TRUE, ...) {
    dotdotdot <- list(...)
    if (length(dotdotdot) > 0L) {
      for (j in seq_along(dotdotdot)) {
        lav_msg_warn(gettextf(
          "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
          sQuote("residuals"))
        )
      }
    }
    # lowercase type
    type <- tolower(type)

    # type = "casewise"
    if (type %in% c("casewise", "case", "obs", "observations", "ov")) {
      return(lav_residuals_casewise(object, labels = labels))
    } else {
      out <- lav_residuals(
        object = object, type = type, h1 = TRUE,
        add.type = TRUE,
        rename.cov.cor = FALSE, # should become FALSE!
        # after packages (eg jmv)
        # have adapted 0.6-3 style
        add.labels = labels, add.class = TRUE,
        drop.list.single.group = TRUE
      )
    }

    out
  }
)

setMethod(
  "resid", "lavaan",
  function(object, type = "raw", ...) {
    dotdotdot <- list(...)
    if (length(dotdotdot) > 0L) {
      for (j in seq_along(dotdotdot)) {
        lav_msg_warn(gettextf(
          "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
          sQuote("resid"))
        )
      }
    }
    residuals(object, type = type, labels = TRUE)
  }
)


# user-visible function
lavResiduals <- function(object, type = "cor.bentler", custom.rmr = NULL,
                         se = FALSE, zstat = TRUE, summary = TRUE,
                         h1.acov = "unstructured",
                         add.type = TRUE, add.labels = TRUE, add.class = TRUE,
                         drop.list.single.group = TRUE,
                         maximum.number = length(res.vech),
                         output = "list") {
  out <- lav_residuals(
    object = object, type = type, h1 = TRUE,
    custom.rmr = custom.rmr, se = se, zstat = zstat,
    summary = summary,
    summary.options = list(
      se = TRUE, zstat = TRUE, pvalue = TRUE,
      unbiased = TRUE, unbiased.se = TRUE, unbiased.ci = TRUE,
      unbiased.ci.level = 0.90, unbiased.zstat = TRUE,
      unbiased.test.val = 0.05, unbiased.pvalue = TRUE
    ),
    h1.acov = h1.acov, add.type = add.type,
    add.labels = add.labels, add.class = add.class,
    drop.list.single.group = drop.list.single.group
  )

  # no pretty printing yet...
  if (output == "table") {
    # new in 0.6-18: handle multiple blocks
    nblocks <- lav_partable_nblocks(object@ParTable)
    out.list <- vector("list", length = nblocks)
    for (block in seq_len(nblocks)) {
      if (nblocks == 1L) {
        res <- out$cov
      } else {
        res <- out[[block]]$cov
      }
      # extract only below-diagonal elements
      res.vech <- lav_matrix_vech(res, diagonal = FALSE)

      # get names
      P <- nrow(res)
      NAMES <- colnames(res)

      nam <- expand.grid(
        NAMES,
        NAMES
      )[lav_matrix_vech_idx(P, diagonal = FALSE), ]
      NAMES.vech <- paste(nam[, 1], "~~", nam[, 2], sep = "")

      # create table
      TAB <- data.frame(
        name = NAMES.vech, res = round(res.vech, 3),
        stringsAsFactors = FALSE
      )

      # sort table
      idx <- sort.int(abs(TAB$res),
        decreasing = TRUE,
        index.return = TRUE
      )$ix
      out.sorted <- TAB[idx, ]

      # show first rows only
      if (maximum.number == 0L || maximum.number > length(res.vech)) {
        maximum.number <- length(res.vech)
      }
      out.list[[block]] <- out.sorted[seq_len(maximum.number), ]
    }
    if (nblocks == 1L) {
      out <- out.list[[1]]
    } else {
      out <- out.list
      names(out) <- object@Data@block.label
    }
  } else {
    # list -> nothing to do
  }

  out
}

# main function
lav_residuals <- function(object, type = "raw", h1 = TRUE, custom.rmr = NULL,
                          se = FALSE, zstat = FALSE, summary = FALSE,
                          summary.options = list(
                            se = TRUE, zstat = TRUE,
                            pvalue = TRUE, unbiased = TRUE, unbiased.se = TRUE,
                            unbiased.ci = TRUE, unbiased.ci.level = 0.90,
                            unbiased.zstat = FALSE, unbiased.test.val = 0.05,
                            unbiased.pvalue = FALSE
                          ),
                          h1.acov = "unstructured", add.type = FALSE,
                          rename.cov.cor = FALSE,
                          add.labels = FALSE, add.class = FALSE,
                          drop.list.single.group = FALSE) {
  # check object
  object <- lav_object_check_version(object)

  # type
  type <- tolower(type)[1]

  # check type
  if (!type %in% c(
    "raw", "cor", "cor.bollen", "cor.bentler", "cor.eqs",
    "rmr", "srmr", "crmr",
    "normalized", "standardized", "standardized.mplus"
  )) {
    lav_msg_stop(gettext("unknown argument for type:"), dQuote(type))
  }

  # if cor, choose 'default'
  if (type == "cor") {
    if (object@Options$mimic == "EQS") {
      type <- "cor.bentler"
    } else {
      type <- "cor.bollen"
    }
  }
  if (type == "cor.eqs") {
    type <- "cor.bentler"
  }
  if (type == "rmr") {
    type <- "raw"
  }
  if (type == "srmr") {
    type <- "cor.bentler"
  }
  if (type == "crmr") {
    type <- "cor.bollen"
  }

  # slots
  lavdata <- object@Data
  lavmodel <- object@Model

  # change options if multilevel (for now)
  if (lavdata@nlevels > 1L) {
    zstat <- se <- FALSE
    summary <- FALSE
  }

  # change options if categorical (for now)
  if (lavmodel@categorical) {
    # only if conditional.x = FALSE AND no continuous endogenous variables
    # -> only the simple setting where we only have thresholds and
    #    correlations

    # As soon as we add continuous variables, we get means/variances too,
    # and we need to decide how WLS.obs/WLS.est/WLS.V will then map to
    # the output of lavInspect(fit, "implied") and
    # lavInspect(fit, "sampstat")

    if (lavmodel@conditional.x || length(unlist(lavmodel@num.idx)) > 0L) {
      zstat <- se <- FALSE
      summary <- FALSE
      summary.options <- list(
        se = FALSE, zstat = FALSE,
        pvalue = FALSE, unbiased = FALSE,
        unbiased.se = FALSE,
        unbiased.ci = FALSE, unbiased.ci.level = 0.90,
        unbiased.zstat = FALSE, unbiased.test.val = 0.05,
        unbiased.pvalue = FALSE
      )
    }
  }

  # change options if conditional.x (for now)
  if (!lavmodel@categorical && lavmodel@conditional.x) {
    zstat <- se <- FALSE
    summary <- FALSE
    summary.options <- list(
      se = FALSE, zstat = FALSE,
      pvalue = FALSE, unbiased = FALSE,
      unbiased.se = FALSE,
      unbiased.ci = FALSE, unbiased.ci.level = 0.90,
      unbiased.zstat = FALSE, unbiased.test.val = 0.05,
      unbiased.pvalue = FALSE
    )
  }

  # observed and fitted sample statistics
  obsList <- lav_object_inspect_sampstat(object,
    h1 = h1,
    add.labels = add.labels, add.class = add.class,
    drop.list.single.group = FALSE
  )
  estList <- lav_object_inspect_implied(object,
    add.labels = add.labels, add.class = add.class,
    drop.list.single.group = FALSE
  )
  # blocks
  nblocks <- length(obsList)

  # pre-scale?
  if (type %in% c("cor.bentler", "cor.bollen")) {
    for (b in seq_len(nblocks)) {
      var.obs <- if (lavmodel@conditional.x) {
        diag(obsList[[b]][["res.cov"]])
      } else {
        diag(obsList[[b]][["cov"]])
      }
      var.est <- if (lavmodel@conditional.x) {
        diag(estList[[b]][["res.cov"]])
      } else {
        diag(estList[[b]][["cov"]])
      }

      # rescale obsList
      obsList[[b]] <-
        lav_residuals_rescale(x = obsList[[b]], diag.cov = var.obs)
      # rescale estList
      if (type == "cor.bentler") { # use obsList
        estList[[b]] <-
          lav_residuals_rescale(x = estList[[b]], diag.cov = var.obs)
      } else if (type == "cor.bollen") { # use estList for COV only
        estList[[b]] <- lav_residuals_rescale(
          x = estList[[b]],
          diag.cov = var.est, diag.cov2 = var.obs
        )
      }
    }
  }

  # compute residuals: (observed - implied)
  resList <- vector("list", length = nblocks)
  for (b in seq_len(nblocks)) {
    resList[[b]] <- lapply(seq_len(length(obsList[[b]])),
      FUN = function(el) {
        obsList[[b]][[el]] - estList[[b]][[el]]
      }
    )
    # always name the elements, even if add.labels = FALSE
    NAMES <- names(obsList[[b]])
    names(resList[[b]]) <- NAMES
  }

  # do we need seList?
  if (se || zstat) {
    seList <- lav_residuals_se(object,
      type = type, z.type = "standardized",
      h1.acov = h1.acov,
      add.class = add.class, add.labels = add.labels
    )
  } else if (type %in% c("normalized", "standardized", "standardized.mplus")) {
    seList <- lav_residuals_se(object,
      type = "raw", z.type = type,
      h1.acov = h1.acov,
      add.class = add.class, add.labels = add.labels
    )
  } else {
    seList <- NULL
  }

  # normalize/standardize?
  if (type %in% c("normalized", "standardized", "standardized.mplus")) {
    for (b in seq_len(nblocks)) {
      if (add.labels) {
        NAMES <- names(resList[[b]])
      }
      resList[[b]] <- lapply(seq_len(length(resList[[b]])),
        FUN = function(el) {
          A <- resList[[b]][[el]]
          B <- seList[[b]][[el]]
          near.zero.idx <- which(abs(A) < 1e-05)
          if (length(near.zero.idx) > 0L) {
            B[near.zero.idx] <- 1
          }
          A / B
        }
      )
      if (add.labels) {
        names(resList[[b]]) <- NAMES
      }
    }
  }

  # add se
  resList.orig <- resList
  if (se) {
    for (b in seq_len(nblocks)) {
      NAMES.res <- names(resList[[b]])
      NAMES.se <- paste0(NAMES.res, ".se")
      resList[[b]] <- c(resList[[b]], seList[[b]])
      names(resList[[b]]) <- c(NAMES.res, NAMES.se)
    }
  }


  # add zstat
  if (zstat) {
    for (b in seq_len(nblocks)) {
      NAMES.res <- names(resList[[b]])
      NAMES.z <- paste0(names(resList.orig[[b]]), ".z")
      tmp <- lapply(seq_len(length(resList.orig[[b]])),
        FUN = function(el) {
          A <- resList.orig[[b]][[el]]
          B <- seList[[b]][[el]]
          # NOTE: which threshold should we use?
          # used to be 1e-05
          # changed to 1e-04 in 0.6-4
          near.zero.idx <- which(abs(A) < 1e-04)
          if (length(near.zero.idx) > 0L) {
            # B[near.zero.idx] <- as.numeric(NA)
            B[near.zero.idx] <- 1.0
          }
          A / B
        }
      )
      resList[[b]] <- c(resList[[b]], tmp)
      names(resList[[b]]) <- c(NAMES.res, NAMES.z)
    }
  }

  # add summary statistics (rms, mabs)
  if (summary) {
    args <- c(
      list(
        object = object, type = type, h1.acov = h1.acov,
        add.class = add.class, custom.rmr = custom.rmr
      ),
      summary.options
    )
    sumStat <- do.call("lav_residuals_summary", args)
    for (b in seq_len(nblocks)) {
      NAMES <- names(resList[[b]])
      resList[[b]] <- c(resList[[b]], list(sumStat[[b]][[1]])) # only 1
      NAMES <- c(NAMES, "summary")
      names(resList[[b]]) <- NAMES
    }
  }

  # last: add type
  if (add.type) {
    for (b in seq_len(nblocks)) {
      NAMES <- names(resList[[b]])
      resList[[b]] <- c(type, resList[[b]])
      NAMES <- c("type", NAMES)
      names(resList[[b]]) <- NAMES
    }
  }

  # optional: rename 'cov' to 'cor' (if type = "cor")
  if (rename.cov.cor && type %in% c("cor.bentler", "cor.bollen")) {
    for (b in seq_len(nblocks)) {
      NAMES <- names(resList[[b]])
      NAMES <- gsub("cov", "cor", NAMES)
      names(resList[[b]]) <- NAMES
    }
  }


  # output
  OUT <- resList
  if (nblocks == 1L && drop.list.single.group) {
    OUT <- OUT[[1]]
  } else {
    if (lavdata@nlevels == 1L &&
      length(lavdata@group.label) > 0L) {
      names(OUT) <- unlist(lavdata@group.label)
    } else if (lavdata@nlevels > 1L &&
      length(lavdata@group.label) == 0L) {
      names(OUT) <- lavdata@level.label
    }
  }

  OUT
}

# return ACOV as list per group
lav_residuals_acov <- function(object, type = "raw", z.type = "standardized",
                               h1.acov = "unstructured") {
  # check type
  if (z.type %in% c("normalized", "standardized.mplus") && type != "raw") {
    lav_msg_stop(gettextf(
      "z.type = %1$s can only be used with type = %2$s",
      dQuote(z.type), dQuote("raw")))
  }

  # slots
  lavdata <- object@Data
  lavmodel <- object@Model
  lavsamplestats <- object@SampleStats

  # return list per group
  ACOV.res <- vector("list", length = lavdata@ngroups)

  # compute ACOV for observed h1 sample statistics (ACOV == Gamma/N)
  if (!is.null(lavsamplestats@NACOV[[1]])) {
    NACOV.obs <- lavsamplestats@NACOV # if this changes, tag @TDJorgensen in commit message
    ACOV.obs <- lapply(NACOV.obs, function(x) x / lavsamplestats@ntotal)
  } else {
    ACOV.obs <- lav_model_h1_acov(
      lavobject = object,
      h1.information = h1.acov
    )
  }

  # shortcut for normalized
  if (z.type == "normalized") {
    ACOV.res <- ACOV.obs
    return(ACOV.res)
  } else {
    if (z.type == "standardized") {
      A1 <- lav_model_h1_information(object)
      if (lavmodel@estimator == "DWLS" || lavmodel@estimator == "ULS") {
        # A1 is diagonal matrix
        A1 <- lapply(A1, diag)
      }
      if (type %in% c("cor.bentler", "cor.bollen")) {
        sampstat <- lavTech(object, "sampstat")
      }
    } else if (z.type == "standardized.mplus") {
      VCOV <- lavTech(object, "vcov")
    }
    DELTA <- lavTech(object, "delta")
  }

  # for each group, compute ACOV
  for (g in seq_len(lavdata@ngroups)) {
    # group weight
    gw <- object@SampleStats@nobs[[g]] / object@SampleStats@ntotal  # if this changes, tag @TDJorgensen in commit message

    if (z.type == "standardized.mplus") { # simplified formula
      # also used by LISREL?
      # see https://www.statmodel.com/download/StandardizedResiduals.pdf

      ACOV.est.g <- DELTA[[g]] %*% VCOV %*% t(DELTA[[g]])
      ACOV.res[[g]] <- ACOV.obs[[g]] - ACOV.est.g
    } else if (z.type == "standardized") {
      # see Ogasawara (2001) using Bentler & Dijkstra (1985) eq 1.7.4

      # NVarCov, but always 'not' robust
      #
      # new in 0.6-6: to ensure Q is a projection matrix, we
      #               force observed.information = "h1"
      #               (only needed if information is observed)
      this.options <- object@Options
      this.options$observed.information[1] <- "h1"
      A0.g.inv <- lav_model_information(
        lavmodel = lavmodel,
        lavsamplestats = object@SampleStats,
        lavdata = lavdata,
        lavcache = object@Cache,
        lavimplied = object@implied,
        lavh1 = object@h1,
        lavoptions = this.options,
        extra = FALSE,
        augmented = TRUE,
        inverted = TRUE,
        use.ginv = TRUE
      )

      ACOV.est.g <- gw * (DELTA[[g]] %*% A0.g.inv %*% t(DELTA[[g]]))
      Q <- diag(nrow = nrow(ACOV.est.g)) - ACOV.est.g %*% A1[[g]]
      ACOV.res[[g]] <- Q %*% ACOV.obs[[g]] %*% t(Q)

      # correct ACOV.res for type = "cor.bentler" or type = "cor.bollen"
      if (type == "cor.bentler") {
        if (lavmodel@categorical) {
          if (lavmodel@conditional.x ||
            length(unlist(lavmodel@num.idx)) > 0L) {
            lav_msg_stop(gettext(
              "SE for cor.bentler not available (yet) if categorical = TRUE, and
              conditional.x = TRUE OR some endogenous variables are continuous"))
          } else {
            # nothing to do, as we already are in correlation metric
          }
        } else {
          # Ogasawara (2001), eq (13), or
          # Maydeu-Olivares (2017), eq (16)
          COV <- if (lavmodel@conditional.x) {
            sampstat[[g]][["res.cov"]]
          } else {
            sampstat[[g]][["cov"]]
          }
          SS <- 1 / sqrt(diag(COV))
          tmp <- lav_matrix_vech(tcrossprod(SS))
          G.inv.sqrt <- diag(tmp, nrow = length(tmp))
          if (lavmodel@meanstructure) {
            GG <- lav_matrix_bdiag(
              diag(SS, nrow = length(SS)),
              G.inv.sqrt
            )
          } else {
            GG <- G.inv.sqrt
          }
          ACOV.res[[g]] <- GG %*% ACOV.res[[g]] %*% GG
        } # continuous
      } else if (type == "cor.bollen") {
        if (lavmodel@categorical) {
          if (lavmodel@conditional.x ||
            length(unlist(lavmodel@num.idx)) > 0L) {
            lav_msg_stop(gettext(
              "SE for cor.bentler not available (yet) if categorical = TRUE, and
              conditional.x = TRUE OR some endogenous variables are continuous"))
          } else {
            # nothing to do, as we already are in correlation metric
          }
        } else {
          # here we use the Maydeu-Olivares (2017) approach, see eq 17
          COV <- if (lavmodel@conditional.x) {
            sampstat[[g]][["res.cov"]]
          } else {
            sampstat[[g]][["cov"]]
          }
          F1 <- lav_deriv_cov2corB(COV)
          if (lavmodel@meanstructure) {
            SS <- 1 / sqrt(diag(COV))
            FF <- lav_matrix_bdiag(diag(SS, nrow = length(SS)), F1)
          } else {
            FF <- F1
          }
          ACOV.res[[g]] <- FF %*% ACOV.res[[g]] %*% t(FF)
        } # continuous
      } # cor.bollen
    } # z.type = "standardized"
  } # g

  ACOV.res
}

# return resList with 'se' values for each residual
lav_residuals_se <- function(object, type = "raw", z.type = "standardized",
                             h1.acov = "unstructured",
                             add.class = FALSE, add.labels = FALSE) {
  # slots
  lavdata <- object@Data
  lavmodel <- object@Model
  lavpta <- object@pta

  # return list per group
  seList <- vector("list", length = lavdata@ngroups)

  # get ACOV per group
  ACOV.res <- lav_residuals_acov(
    object = object, type = type,
    z.type = z.type, h1.acov = h1.acov
  )

  # labels
  if (add.labels) {
    ov.names <- object@pta$vnames$ov
    ov.names.res <- object@pta$vnames$ov.nox
    ov.names.x <- object@pta$vnames$ov.x
  }

  # for each group, compute 'se' values, and fill list
  for (g in seq_len(lavdata@ngroups)) {
    nvar <- object@pta$nvar[[g]] # block or group-based?
    diag.ACOV <- diag(ACOV.res[[g]])

    # take care of negative, or non-finite diag.ACOV elements
    diag.ACOV[!is.finite(diag.ACOV)] <- NA
    diag.ACOV[diag.ACOV < 0] <- NA

    # categorical
    if (lavmodel@categorical) {
      if (lavmodel@conditional.x ||
        length(unlist(lavmodel@num.idx)) > 0L) {
        lav_msg_stop(gettext("not ready yet!"))
      }

      # COR
      nth <- length(lavmodel@th.idx[[g]])
      tmp <- sqrt(diag.ACOV[-(1:nth)])
      cov.se <- lav_matrix_vech_reverse(tmp, diagonal = FALSE)

      # MEAN
      mean.se <- rep(as.numeric(NA), nvar)

      # TH
      th.se <- sqrt(diag.ACOV[1:nth])

      if (add.class) {
        class(cov.se) <- c("lavaan.matrix.symmetric", "matrix")
        class(mean.se) <- c("lavaan.vector", "numeric")
        class(th.se) <- c("lavaan.vector", "numeric")
      }
      if (add.labels) {
        rownames(cov.se) <- colnames(cov.se) <- ov.names[[g]]
        names(mean.se) <- ov.names[[g]]
        names(th.se) <- lavpta$vnames$th.mean[[g]]
      }
      seList[[g]] <- list(
        cov.se = cov.se, mean.se = mean.se,
        th.se = th.se
      )

      # continuous -- single level
    } else if (lavdata@nlevels == 1L) {
      if (lavmodel@conditional.x) {
        lav_msg_stop(gettext("not ready yet"))
      } else {
        if (lavmodel@meanstructure) {
          tmp <- sqrt(diag.ACOV[-(1:nvar)])
          cov.se <- lav_matrix_vech_reverse(tmp)
          mean.se <- sqrt(diag.ACOV[1:nvar])
          if (add.class) {
            class(cov.se) <- c("lavaan.matrix.symmetric", "matrix")
            class(mean.se) <- c("lavaan.vector", "numeric")
          }
          if (add.labels) {
            rownames(cov.se) <- colnames(cov.se) <- ov.names[[g]]
            names(mean.se) <- ov.names[[g]]
          }
          seList[[g]] <- list(cov.se = cov.se, mean.se = mean.se)
        } else {
          cov.se <- lav_matrix_vech_reverse(sqrt(diag.ACOV))
          if (add.class) {
            class(cov.se) <- c("lavaan.matrix.symmetric", "matrix")
          }
          if (add.labels) {
            rownames(cov.se) <- colnames(cov.se) <- ov.names[[g]]
          }
          seList[[g]] <- list(cov.se = cov.se)
        }
      }

      # continuous -- multilevel
    } else if (lavdata@nlevels > 1L) {
      lav_msg_stop(gettext("not ready yet"))
    }
  } # g

  seList
}

# return summary statistics as list per group
lav_residuals_summary <- function(object, type = c("rmr", "srmr", "crmr"),
                                  h1.acov = "unstructured", custom.rmr = NULL,
                                  se = FALSE, zstat = FALSE, pvalue = FALSE,
                                  unbiased = FALSE, unbiased.se = FALSE,
                                  unbiased.ci = FALSE, unbiased.ci.level = 0.90,
                                  unbiased.zstat = FALSE,
                                  unbiased.test.val = 0.05,
                                  unbiased.pvalue = FALSE,
                                  add.class = FALSE) {
  # arguments
  if (length(custom.rmr)) {
    if (!is.list(custom.rmr)) lav_msg_stop(gettext("custom.rmr must be a list"))
    ## Each custom (S/C)RMR must have a unique name
    customNAMES <- names(custom.rmr)
    if (is.null(customNAMES)) lav_msg_stop(gettext(
      "custom.rmr list must have names"))
    if (length(unique(customNAMES)) < length(custom.rmr)) {
      lav_msg_stop(gettext(
        "custom.rmr must have a unique name for each summary"))
    }
    ## Each list must contain a list consisting of $cov and/or $mean (no $th yet)
    for (i in seq_along(custom.rmr)) {
      if (!is.list(custom.rmr[[i]])) {
        lav_msg_stop(gettext("Each element in custom.rmr must be a list"))
      }
      if (is.null(names(custom.rmr[[i]]))) {
        lav_msg_stop(gettext("The list in custom.rmr must have names"))
      }
      if (!all(names(custom.rmr[[i]]) %in% c("cov", "mean"))) {
        lav_msg_stop(gettext(
          'Elements in custom.rmr must be names "cov" and/or "mean"'))
      }
      ## below, verify dimensions match rmsList.g
    }
    # FIXME: blocks can have unique models, need another layer of lists
    #       between custom summaries and moments
  } else {
    customNAMES <- NULL
  }

  if (pvalue) {
    zstat <- TRUE
  }
  if (zstat) {
    se <- TRUE
  }
  if (unbiased.pvalue) {
    unbiased.zstat <- TRUE
  }
  if (unbiased.zstat) {
    unbiased.se <- TRUE
  }

  if (!all(type %in% c(
    "rmr", "srmr", "crmr",
    "raw", "cor.bentler", "cor.bollen"
  ))) {
    lav_msg_stop(gettext("unknown type:"), dQuote(type))
  }

  # change type name
  idx <- which(type == "raw")
  if (length(idx) > 0L) {
    type[idx] <- "rmr"
  }
  idx <- which(type == "cor.bentler")
  if (length(idx) > 0L) {
    type[idx] <- "srmr"
  }
  idx <- which(type == "cor.bollen")
  if (length(idx) > 0L) {
    type[idx] <- "crmr"
  }

  # slots
  lavdata <- object@Data
  lavmodel <- object@Model

  # fixed.x/conditional.x
  fixed.x <- lavmodel@fixed.x
  conditional.x <- lavmodel@conditional.x


  rmrFlag <- srmrFlag <- crmrFlag <- FALSE
  if ("rmr" %in% type || "raw" %in% type) {
    # FIXME: recursive call to lav_residuals() is summary = TRUE!!
    rmrList <- lav_residuals(object = object, type = "raw")
    if (se || unbiased) {
      rmrList.se <- lav_residuals_acov(
        object = object, type = "raw",
        z.type = "standardized",
        h1.acov = "unstructured"
      )
    }
  }
  if ("srmr" %in% type || "cor.bentler" %in% type || "cor" %in% type) {
    srmrList <- lav_residuals(object = object, type = "cor.bentler")
    if (se || unbiased) {
      srmrList.se <- lav_residuals_acov(
        object = object,
        type = "cor.bentler",
        z.type = "standardized",
        h1.acov = "unstructured"
      )
    }
  }
  if ("crmr" %in% type || "cor.bollen" %in% type) {
    crmrList <- lav_residuals(object = object, type = "cor.bollen")
    if (se || unbiased) {
      crmrList.se <- lav_residuals_acov(
        object = object,
        type = "cor.bollen",
        z.type = "standardized",
        h1.acov = "unstructured"
      )
    }
  }

  # return list per group
  sumStat <- vector("list", length = lavdata@ngroups)

  # for each group, compute ACOV
  for (g in seq_len(lavdata@ngroups)) {
    nvar <- object@pta$nvar[[g]] # block or group-based?

    # categorical single level
    if (lavdata@nlevels == 1L && lavmodel@categorical) {
      if ((se || unbiased) && (conditional.x ||
        length(unlist(lavmodel@num.idx)) > 0L)) {
        lav_msg_stop(gettext("not ready yet"))
      } else {
        # remove fixed.x elements:
        # seems like a good idea, but nobody likes it
        # nvar.x <- pstar.x <- 0L
        # if(lavmodel@fixed.x) {
        #     nvar.x <- lavmodel@nexo[g]
        #     pstar.x <- nvar.x * (nvar.x - 1) / 2 # note '-'
        # }

        OUT <- vector("list", length(type))
        names(OUT) <- type

        for (typ in seq_len(length(type))) {
          if (type[typ] == "rmr") {
            rmsList.g <- rmrList[[g]]
            if (se || unbiased) {
              rmsList.se.g <- rmrList.se[[g]]
            }
          } else if (type[typ] == "srmr") {
            rmsList.g <- srmrList[[g]]
            if (se || unbiased) {
              rmsList.se.g <- srmrList.se[[g]]
            }
          } else if (type[typ] == "crmr") {
            rmsList.g <- crmrList[[g]]
            if (se || unbiased) {
              rmsList.se.g <- crmrList.se[[g]]
            }
          }

          # COR
          nth <- length(lavmodel@th.idx[[g]])
          if (conditional.x) {
            STATS <- lav_matrix_vech(rmsList.g[["res.cov"]],
              diagonal = FALSE
            )
          } else {
            STATS <- lav_matrix_vech(rmsList.g[["cov"]],
              diagonal = FALSE
            )
          }

          # should pstar be p*(p+1)/2 or p*(p-1)/2
          # we use the first for SRMR and the latter for CRMR
          if (type[typ] == "crmr") {
            pstar <- length(STATS)
          } else {
            pstar <- length(STATS) + nvar
          }
          ACOV <- NULL
          if (se || unbiased) {
            ACOV <- rmsList.se.g[-seq_len(nth),
              -seq_len(nth),
              drop = FALSE
            ]
          }
          RMS.COR <- lav_residuals_summary_rms(
            STATS = STATS,
            ACOV = ACOV, se = se, zstat = zstat, pvalue = pvalue,
            unbiased = unbiased, unbiased.se = unbiased.se,
            unbiased.ci = unbiased.ci,
            unbiased.ci.level = unbiased.ci.level,
            unbiased.zstat = unbiased.zstat,
            unbiased.test.val = unbiased.test.val,
            unbiased.pvalue = unbiased.pvalue,
            pstar = pstar, type = type[typ]
          )


          # THRESHOLDS
          if (conditional.x) {
            STATS <- rmsList.g[["res.th"]]
          } else {
            STATS <- rmsList.g[["th"]]
          }
          pstar <- length(STATS)
          ACOV <- NULL
          if (se || unbiased) {
            ACOV <- rmsList.se.g[seq_len(nth),
              seq_len(nth),
              drop = FALSE
            ]
          }
          RMS.TH <- lav_residuals_summary_rms(
            STATS = STATS,
            ACOV = ACOV, se = se, zstat = zstat, pvalue = pvalue,
            unbiased = unbiased, unbiased.se = unbiased.se,
            unbiased.ci = unbiased.ci,
            unbiased.ci.level = unbiased.ci.level,
            unbiased.zstat = unbiased.zstat,
            unbiased.test.val = unbiased.test.val,
            unbiased.pvalue = unbiased.pvalue,
            pstar = pstar, type = type[typ]
          )

          # MEAN
          # STATS <- rmsList.g[["mean"]]
          STATS <- numeric(0L)
          pstar <- length(STATS)
          ACOV <- NULL
          if (se || unbiased) {
            # TODO: extract from rmsList.se.g
          }
          RMS.MEAN <- lav_residuals_summary_rms(
            STATS = STATS,
            ACOV = ACOV, se = se, zstat = zstat, pvalue = pvalue,
            unbiased = unbiased, unbiased.se = unbiased.se,
            unbiased.ci = unbiased.ci,
            unbiased.ci.level = unbiased.ci.level,
            unbiased.zstat = unbiased.zstat,
            unbiased.test.val = unbiased.test.val,
            unbiased.pvalue = unbiased.pvalue,
            pstar = pstar, type = type[typ]
          )

          # VAR (not ready yet)
          # STATS <- diag(rmsList.g[["cov"]])[lavmodel@num.idx[[g]]]
          STATS <- numeric(0L)
          pstar <- length(STATS)
          ACOV <- NULL
          if (se || unbiased) {
            # TODO: extract from rmsList.se.g
          }
          RMS.VAR <- lav_residuals_summary_rms(
            STATS = STATS,
            ACOV = ACOV, se = se, zstat = zstat, pvalue = pvalue,
            unbiased = unbiased, unbiased.se = unbiased.se,
            unbiased.ci = unbiased.ci,
            unbiased.ci.level = unbiased.ci.level,
            unbiased.zstat = unbiased.zstat,
            unbiased.test.val = unbiased.test.val,
            unbiased.pvalue = unbiased.pvalue,
            pstar = pstar, type = type[typ]
          )

          # TOTAL -- FIXME: for conditional.x ....
          if (conditional.x) {
            STATS <- c(
              lav_matrix_vech(rmsList.g[["res.cov"]],
                diagonal = FALSE
              ),
              rmsList.g[["res.th"]]
            )
          } else {
            STATS <- c(
              lav_matrix_vech(rmsList.g[["cov"]],
                diagonal = FALSE
              ),
              rmsList.g[["th"]]
            )
            # rmsList.g[["mean"]],
            # diag(rmsList.g[["cov"]])[lavmodel@num.idx[[g]]])
          }

          # should pstar be p*(p+1)/2 or p*(p-1)/2 for COV/COR?
          # we use the first for SRMR and the latter for CRMR
          if (type[typ] == "crmr") {
            pstar <- length(STATS)
          } else {
            pstar <- length(STATS) + nvar
          }

          # if(lavmodel@fixed.x) {
          #    pstar <- pstar - pstar.x
          # }

          ACOV <- NULL
          if (se || unbiased) {
            ACOV <- rmsList.se.g
          }
          RMS.TOTAL <- lav_residuals_summary_rms(
            STATS = STATS,
            ACOV = ACOV, se = se, zstat = zstat, pvalue = pvalue,
            unbiased = unbiased, unbiased.se = unbiased.se,
            unbiased.ci = unbiased.ci,
            unbiased.ci.level = unbiased.ci.level,
            unbiased.zstat = unbiased.zstat,
            unbiased.test.val = unbiased.test.val,
            unbiased.pvalue = unbiased.pvalue,
            pstar = pstar, type = type[typ]
          )

          TABLE <- as.data.frame(cbind(
            RMS.COR,
            RMS.TH,
            # RMS.MEAN,
            # RMS.VAR,
            RMS.TOTAL
          ))
          # colnames(TABLE) <- c("cor", "thresholds", "mean",
          #                     "var", "total")
          colnames(TABLE) <- c("cor", "thresholds", "total")
          if (add.class) {
            class(TABLE) <- c("lavaan.data.frame", "data.frame")
          }
          OUT[[typ]] <- TABLE
        } # type
      } # not conditional.x or mixed cat/con

      # continuous -- single level
    } else if (lavdata@nlevels == 1L) {
      if ((se || unbiased) && conditional.x) {
        lav_msg_stop(gettext("not ready yet"))
      } else {
        # nvar.x <- pstar.x <- 0L
        # if(lavmodel@fixed.x) {
        #    nvar.x <- lavmodel@nexo[g]
        #    pstar.x <- nvar.x * (nvar.x + 1) / 2
        # }

        OUT <- vector("list", length(type))
        names(OUT) <- type

        for (typ in seq_len(length(type))) {
          if (type[typ] == "rmr") {
            rmsList.g <- rmrList[[g]]
            if (se || unbiased) {
              rmsList.se.g <- rmrList.se[[g]]
            }
          } else if (type[typ] == "srmr") {
            rmsList.g <- srmrList[[g]]
            if (se || unbiased) {
              rmsList.se.g <- srmrList.se[[g]]
            }
          } else if (type[typ] == "crmr") {
            rmsList.g <- crmrList[[g]]
            if (se || unbiased) {
              rmsList.se.g <- crmrList.se[[g]]
            }
          }

          # COV
          if (conditional.x) {
            STATS <- lav_matrix_vech(rmsList.g[["res.cov"]])
          } else {
            STATS <- lav_matrix_vech(rmsList.g[["cov"]])
          }
          # pstar <- ( length(STATS) - pstar.x )
          pstar <- length(STATS)
          if (type[typ] == "crmr") {
            # pstar <- pstar - ( nvar - nvar.x )
            if (conditional.x) {
              pstar <- pstar - nrow(rmsList.g[["res.cov"]])
            } else {
              pstar <- pstar - nvar
            }
          }

          ACOV <- NULL
          if (se || unbiased) {
            ACOV <- if (lavmodel@meanstructure) {
              rmsList.se.g[-seq_len(nvar),
                -seq_len(nvar),
                drop = FALSE
              ]
            } else {
              rmsList.se.g
            }
          }
          RMS.COV <- lav_residuals_summary_rms(
            STATS = STATS,
            ACOV = ACOV, se = se, zstat = zstat, pvalue = pvalue,
            unbiased = unbiased, unbiased.se = unbiased.se,
            unbiased.ci = unbiased.ci,
            unbiased.ci.level = unbiased.ci.level,
            unbiased.zstat = unbiased.zstat,
            unbiased.test.val = unbiased.test.val,
            unbiased.pvalue = unbiased.pvalue,
            pstar = pstar, type = type[typ]
          )

          # MEAN
          if (lavmodel@meanstructure) {
            if (conditional.x) {
              STATS <- rmsList.g[["res.int"]]
            } else {
              STATS <- rmsList.g[["mean"]]
            }
            # pstar <- ( length(STATS) - nvar.x )
            pstar <- length(STATS)
            ACOV <- NULL
            if (se || unbiased) {
              ACOV <- rmsList.se.g[seq_len(nvar),
                seq_len(nvar),
                drop = FALSE
              ]
            }
            RMS.MEAN <- lav_residuals_summary_rms(
              STATS = STATS,
              ACOV = ACOV,
              se = se, zstat = zstat, pvalue = pvalue,
              unbiased = unbiased, unbiased.se = unbiased.se,
              unbiased.ci = unbiased.ci,
              unbiased.ci.level = unbiased.ci.level,
              unbiased.zstat = unbiased.zstat,
              unbiased.test.val = unbiased.test.val,
              unbiased.pvalue = unbiased.pvalue,
              pstar = pstar, type = type[typ]
            )
          }

          # TOTAL
          if (lavmodel@meanstructure) {
            if (conditional.x) {
              STATS <- c(
                rmsList.g[["res.int"]],
                lav_matrix_vech(rmsList.g[["res.cov"]])
              )
            } else {
              STATS <- c(
                rmsList.g[["mean"]],
                lav_matrix_vech(rmsList.g[["cov"]])
              )
            }
            # pstar <- ( length(STATS) - ( pstar.x + nvar.x) )
            pstar <- length(STATS)
            if (type[typ] == "crmr") {
              # pstar <- pstar - ( nvar - nvar.x )
              pstar <- pstar - nvar
            }
            ACOV <- NULL
            if (se || unbiased) {
              ACOV <- rmsList.se.g
            }
            RMS.TOTAL <- lav_residuals_summary_rms(
              STATS = STATS,
              ACOV = ACOV,
              se = se, zstat = zstat, pvalue = pvalue,
              unbiased = unbiased, unbiased.se = unbiased.se,
              unbiased.ci = unbiased.ci,
              unbiased.ci.level = unbiased.ci.level,
              unbiased.zstat = unbiased.zstat,
              unbiased.test.val = unbiased.test.val,
              unbiased.pvalue = unbiased.pvalue,
              pstar = pstar, type = type[typ]
            )
          }

          # CUSTOM
          if (length(custom.rmr)) {
            if (lavmodel@fixed.x && !lavmodel@conditional.x) {
              ## save exogenous-variable indices, use to remove or set
              ## FALSE any moments that cannot have nonzero residuals
              x.idx <- which(rownames(rmsList.g$cov) %in% object@Data@ov.names.x[[g]])
            }

            RMS.CUSTOM.LIST <- vector("list", length(customNAMES))

            for (cus in customNAMES) {
              ## in case there is no meanstructure
              STATS <- NULL
              ACOV.idx <- NULL

              # MEANS?
              if (lavmodel@meanstructure) {
                if ("mean" %in% names(custom.rmr[[cus]])) {
                  ## if logical, save numeric indices
                  if (is.logical(custom.rmr[[cus]]$mean)) {
                    ## check length
                    if (length(custom.rmr[[cus]]$mean) != length(rmsList.g[["mean"]])) {
                      lav_msg_stop(gettextf("length(custom.rmr$%s$mean) must
                            match length(lavResiduals(fit)$mean)", cus))
                    }
                    ACOV.idx <- which(custom.rmr[[cus]]$mean)
                    if (lavmodel@fixed.x && !lavmodel@conditional.x) {
                      ACOV.idx[x.idx] <- FALSE
                    }
                  } else if (!is.numeric(custom.rmr[[cus]]$mean)) {
                    lav_msg_stop(gettextf("custom.rmr$%s$mean must contain
                                  logical or numeric indices.", cus))
                  } else {
                    ACOV.idx <- custom.rmr[[cus]]$mean
                    if (lavmodel@fixed.x && !lavmodel@conditional.x) {
                      ACOV.idx <- setdiff(ACOV.idx, x.idx)
                    }
                    ACOV.idx <- ACOV.idx[!is.na(ACOV.idx)] # necessary?
                    if (max(ACOV.idx) > length(rmsList.g[["mean"]])) {
                      lav_msg_stop(gettextf(
                        "custom.rmr$%1$s$mean[%2$s] is an out-of-bounds index",
                        cus, which.max(ACOV.idx))
                      )
                    }
                  }
                  STATS <- rmsList.g[["mean"]][ACOV.idx]
                }
              }
              # (CO)VARIANCES?
              if ("cov" %in% names(custom.rmr[[cus]])) {
                ## if numeric, create a logical matrix to obtain
                ## ACOV.idx and check for x.idx
                if (is.numeric(custom.rmr[[cus]]$cov)) {
                  cusCOV <- rmsList.g[["cov"]] == "start with all FALSE"
                  ## matrix of row/column indices?
                  if (length(dim(custom.rmr[[cus]]$cov))) {
                    if (max(custom.rmr[[cus]]$cov[, 1:2] > nrow(rmsList.g[["cov"]]))) {
                      lav_msg_stop(gettextf(
                        "numeric indices in custom.rmr$%1$s$cov cannot
                        exceed %2$s", cus, nrow(rmsList.g[["cov"]])))
                    }
                    for (RR in 1:nrow(custom.rmr[[cus]]$cov)) {
                      cusCOV[
                        custom.rmr[[cus]]$cov[RR, 1],
                        custom.rmr[[cus]]$cov[RR, 2]
                      ] <- TRUE
                    }
                  } else {
                    ## numeric-vector indices
                    if (max(custom.rmr[[cus]]$cov > length(rmsList.g[["cov"]]))) {
                      lav_msg_stop(gettextf(
                        "numeric indices in custom.rmr$%1$s$cov cannot
                        exceed %2$s", cus, length(rmsList.g[["cov"]])))
                    }
                    cusCOV[custom.rmr[[cus]]$cov] <- TRUE
                  }

                  ## numeric indices no longer needed, use logical
                  custom.rmr[[cus]]$cov <- cusCOV
                } else if (!is.logical(custom.rmr[[cus]]$cov)) {
                  lav_msg_stop(gettextf(
                    "custom.rmr$%s$cov must be a logical square matrix or a
                    numeric matrix of (row/column) indices.", cus))
                }

                ## check dimensions
                if (!all(dim(custom.rmr[[cus]]$cov) == dim(rmsList.g[["cov"]]))) {
                  lav_msg_stop(gettextf(
                    "dim(custom.rmr$%s$cov) must match
                    dim(lavResiduals(fit)$cov)", cus))
                }
                ## users can specify upper.tri or lower.tri indices
                custom.rmr[[cus]]$cov <- custom.rmr[[cus]]$cov | t(custom.rmr[[cus]]$cov)
                ## but ACOV refers to lower.tri indices
                custom.rmr[[cus]]$cov[upper.tri(custom.rmr[[cus]]$cov)] <- FALSE
                ## diagonal relevant?
                if (type[typ] == "crmr") diag(custom.rmr[[cus]]$cov) <- FALSE
                ## extract lower.tri indices
                vech.idx <- which(lav_matrix_vech(custom.rmr[[cus]]$cov))

                ## add residuals to STATS, indices to ACOV.idx
                STATS <- c(STATS, lav_matrix_vech(rmsList.g[["cov"]])[vech.idx])
                ACOV.idx <- c(ACOV.idx, vech.idx)
              }


              ## count residuals in summary (x.idx already removed)
              pstar <- length(STATS)

              ACOV <- NULL
              if (se || unbiased) {
                ACOV <- rmsList.se.g[ACOV.idx, ACOV.idx, drop = FALSE]
              }
              RMS.CUSTOM.LIST[[cus]] <- lav_residuals_summary_rms(
                STATS = STATS,
                ACOV = ACOV,
                se = se, zstat = zstat, pvalue = pvalue,
                unbiased = unbiased, unbiased.se = unbiased.se,
                unbiased.ci = unbiased.ci,
                unbiased.ci.level = unbiased.ci.level,
                unbiased.zstat = unbiased.zstat,
                unbiased.test.val = unbiased.test.val,
                unbiased.pvalue = unbiased.pvalue,
                pstar = pstar, type = type[typ]
              )

              # FIXME: update for categorical
            } # cus
            RMS.CUSTOM <- do.call(rbind, RMS.CUSTOM.LIST)
          } else {
            RMS.CUSTOM <- NULL
          }


          if (lavmodel@meanstructure) {
            TABLE <- as.data.frame(cbind(
              RMS.COV,
              RMS.MEAN,
              RMS.TOTAL,
              RMS.CUSTOM
            ))
            colnames(TABLE) <- c(
              "cov", "mean", "total",
              customNAMES
            )
          } else {
            TABLE <- as.data.frame(cbind(RMS.COV, RMS.CUSTOM))
            colnames(TABLE) <- c("cov", customNAMES)
          }
          if (add.class) {
            class(TABLE) <- c("lavaan.data.frame", "data.frame")
          }
          OUT[[typ]] <- TABLE
        } # type
      } # continuous, single-level, unconditional

      # continuous -- multilevel
    } else if (lavdata@nlevels > 1L) {
      lav_msg_stop(gettext("not ready yet"))
    }

    sumStat[[g]] <- OUT
  } # g

  sumStat
}


lav_residuals_summary_rms <- function(STATS = NULL, ACOV = NULL,
                                      se = FALSE,
                                      level = 0.90,
                                      zstat = FALSE, pvalue = FALSE,
                                      unbiased = FALSE,
                                      unbiased.se = FALSE,
                                      unbiased.ci = FALSE,
                                      unbiased.ci.level = 0.90,
                                      unbiased.zstat = FALSE,
                                      unbiased.test.val = 0.05,
                                      unbiased.pvalue = FALSE,
                                      pstar = 0, type = "rms") {
  OUT <- vector("list", length = 0L)


  # covariance matrix
  if (length(STATS) > 0L) {
    rms <- sqrt(sum(STATS * STATS) / pstar)
  } else {
    rms <- 0
    se <- unbiased <- zstat <- FALSE
  }

  # default is NULL
  rms.se <- rms.z <- rms.pvalue <- NULL
  urms <- urms.se <- urms.z <- urms.pvalue <- NULL
  urms.ci.lower <- urms.ci.upper <- NULL
  if (!unbiased.zstat) {
    unbiased.test.val <- NULL
  }

  if (se || unbiased) {
    TR2 <- sum(diag(ACOV %*% ACOV))
    TR1 <- sum(diag(ACOV))
    if (se) {
      rms.avar <- TR2 / (TR1 * 2 * pstar)
      if (!is.finite(rms.avar) || rms.avar < .Machine$double.eps) {
        rms.se <- as.numeric(NA)
      } else {
        rms.se <- sqrt(rms.avar)
      }
    }
  }

  if (zstat) {
    E.rms <- (sqrt(TR1 / pstar) * (4 * TR1 * TR1 - TR2) / (4 * TR1 * TR1))
    rms.z <- max((rms - E.rms), 0) / rms.se
    if (pvalue) {
      rms.pvalue <- 1 - pnorm(rms.z)
    }
  }

  if (unbiased) {
    T.cov <- as.numeric(crossprod(STATS))
    eVe <- as.numeric(t(STATS) %*% ACOV %*% STATS)
    k.cov <- 1 - (TR2 + 2 * eVe) / (4 * T.cov * T.cov)
    urms <- (1 / k.cov * sqrt(max((T.cov - TR1), 0) / pstar))
    if (unbiased.se) {
      urms.avar <- (1 / (k.cov * k.cov) * (TR2 + 2 * eVe) / (2 * pstar * T.cov))
      if (!is.finite(urms.avar) || urms.avar < .Machine$double.eps) {
        urms.se <- as.numeric(NA)
      } else {
        urms.se <- sqrt(urms.avar)
      }
      if (unbiased.ci) {
        a <- (1 - unbiased.ci.level) / 2
        a <- c(a, 1 - a)
        fac <- stats::qnorm(a)
        urms.ci.lower <- urms + urms.se * fac[1]
        urms.ci.upper <- urms + urms.se * fac[2]
      }
      if (unbiased.zstat) {
        urms.z <- (urms - unbiased.test.val) / urms.se
        if (unbiased.pvalue) {
          urms.pvalue <- 1 - pnorm(urms.z)
        }
      }
    }
  }

  # labels
  if (type == "rmr") {
    OUT <- list(
      rmr = rms, rmr.se = rms.se,
      rmr.exactfit.z = rms.z, rmr.exactfit.pvalue = rms.pvalue,
      urmr = urms, urmr.se = urms.se,
      urmr.ci.lower = urms.ci.lower,
      urmr.ci.upper = urms.ci.upper,
      urmr.closefit.h0.value = unbiased.test.val,
      urmr.closefit.z = urms.z,
      urmr.closefit.pvalue = urms.pvalue
    )
  } else if (type == "srmr") {
    OUT <- list(
      srmr = rms, srmr.se = rms.se,
      srmr.exactfit.z = rms.z, srmr.exactfit.pvalue = rms.pvalue,
      usrmr = urms, usrmr.se = urms.se,
      usrmr.ci.lower = urms.ci.lower,
      usrmr.ci.upper = urms.ci.upper,
      usrmr.closefit.h0.value = unbiased.test.val,
      usrmr.closefit.z = urms.z,
      usrmr.closefit.pvalue = urms.pvalue
    )
  } else if (type == "crmr") {
    OUT <- list(
      crmr = rms, crmr.se = rms.se,
      crmr.exactfit.z = rms.z, crmr.exactfit.pvalue = rms.pvalue,
      ucrmr = urms, ucrmr.se = urms.se,
      ucrmr.ci.lower = urms.ci.lower,
      ucrmr.ci.upper = urms.ci.upper,
      ucrmr.closefit.h0.value = unbiased.test.val,
      ucrmr.closefit.z = urms.z,
      ucrmr.closefit.pvalue = urms.pvalue
    )
  }

  unlist(OUT)
}

# generate summary statistics for the residuals
lav_residuals_summary_old <- function(resList = NULL,
                                      add.class = FALSE, add.labels = FALSE) {
  # per block
  nblocks <- length(resList)

  for (b in seq_len(nblocks)) {
    # create new list, including with summary statistics interleaved
    x <- vector("list", length = 0L)
    nel <- length(resList[[b]])
    NAMES <- names(resList[[b]])

    for (el in seq_len(nel)) {
      EL <- resList[[b]][[el]]
      if (!is.null(NAMES)) {
        NAME <- NAMES[el]
      }

      if (is.character(EL)) {
        new.x <- list(EL)
        if (add.labels) {
          names(new.x) <- "type"
        }
        x <- c(x, new.x)
      } else if (is.matrix(EL) && isSymmetric(EL)) {
        tmp <- na.omit(lav_matrix_vech(EL))
        rms <- sqrt(sum(tmp * tmp) / length(tmp))
        mabs <- mean(abs(tmp))
        tmp2 <- na.omit(lav_matrix_vech(EL, diagonal = FALSE))
        rms.nodiag <- sqrt(sum(tmp2 * tmp2) / length(tmp2))
        mabs.nodiag <- mean(abs(tmp2))
        cov.summary <- c(rms, rms.nodiag, mabs, mabs.nodiag)
        if (add.labels) {
          names(cov.summary) <-
            c("rms", "rms.nodiag", "mabs", "mabs.nodiag")
        }
        if (add.class) {
          class(cov.summary) <- c("lavaan.vector", "numeric")
        }
        new.x <- list(EL, cov.summary)
        if (add.labels && !is.null(NAMES)) {
          names(new.x) <- c(NAME, paste0(NAME, ".summary"))
        }
        x <- c(x, new.x)
      } else {
        tmp <- na.omit(EL)
        rms <- sqrt(sum(tmp * tmp) / length(tmp))
        mabs <- mean(abs(tmp))
        mean.summary <- c(rms, mabs)
        if (add.labels) {
          names(mean.summary) <- c("rms", "mabs")
        }
        if (add.class) {
          class(mean.summary) <- c("lavaan.vector", "numeric")
        }
        new.x <- list(EL, mean.summary)
        if (add.labels && !is.null(NAMES)) {
          names(new.x) <- c(NAME, paste0(NAME, ".summary"))
        }
        x <- c(x, new.x)
      }
    } # nel

    # fill in block including summary statistics
    resList[[b]] <- x
  } # nblocks

  resList
}


# x is a list with sample statistics (eg output of lavInspect(fit, "sampstat")
# y is another (possibly the same) list with sample statistics
#
# to avoid many 'NAs', we set the scale-factor to 1
# if the to-be-scaled value is < 1e-05 (in absolute value)
lav_residuals_rescale <- function(x, diag.cov = NULL, diag.cov2 = NULL) {
  if (is.null(diag.cov2)) {
    diag.cov2 <- diag.cov
  }

  # make sure we can take the sqrt and invert
  diag.cov[!is.finite(diag.cov)] <- NA
  diag.cov[diag.cov < .Machine$double.eps] <- NA
  scale.cov <- tcrossprod(1 / sqrt(diag.cov))

  # for the mean, we use diag.cov2
  diag.cov2[!is.finite(diag.cov2)] <- NA
  diag.cov2[diag.cov2 < .Machine$double.eps] <- NA
  scale.mean <- 1 / sqrt(diag.cov2)

  # rescale cov
  if (!is.null(x[["cov"]])) {
    # catch (near) zero elements in x$cov
    near.zero.idx <- which(abs(x[["cov"]]) < 1e-05)
    scale.cov[near.zero.idx] <- 1
    x[["cov"]][] <- x[["cov"]] * scale.cov
  }
  if (!is.null(x[["res.cov"]])) {
    # catch (near) zero elements in x$res.cov
    near.zero.idx <- which(abs(x[["res.cov"]]) < 1e-05)
    scale.cov[near.zero.idx] <- 1
    x[["res.cov"]][] <- x[["res.cov"]] * scale.cov
  }

  # rescale int/mean
  if (!is.null(x[["res.int"]])) {
    # catch (near) zero elements in x$res.int
    near.zero.idx <- which(abs(x[["res.int"]]) < 1e-05)
    scale.mean[near.zero.idx] <- 1
    x[["res.int"]] <- x[["res.int"]] * scale.mean
  }

  if (!is.null(x[["mean"]])) {
    # catch (near) zero elements in x$mean
    near.zero.idx <- which(abs(x[["mean"]]) < 1e-05)
    scale.mean[near.zero.idx] <- 1
    x[["mean"]] <- x[["mean"]] * scale.mean
  }

  # FIXME: do something sensible for th, slopes, ...

  x
}

lav_partable_flat <- function(FLAT = NULL, # nolint
                              blocks = "group",
                              block.id = NULL,
                              meanstructure = FALSE,
                              int.ov.free = FALSE,
                              int.lv.free = FALSE,
                              orthogonal = FALSE,
                              orthogonal.y = FALSE,
                              orthogonal.x = FALSE,
                              orthogonal.efa = FALSE,
                              std.lv = FALSE,
                              correlation = FALSE,
                              composites = TRUE,
                              conditional.x = FALSE,
                              fixed.x = TRUE,
                              parameterization = "delta",
                              auto.fix.first = FALSE,
                              auto.fix.single = FALSE,
                              auto.var = FALSE,
                              auto.cov.lv.x = FALSE,
                              auto.cov.y = FALSE,
                              auto.th = FALSE,
                              auto.delta = FALSE,
                              auto.efa = FALSE,
                              varTable = NULL, # nolint
                              group.equal = NULL,
                              group.w.free = FALSE,
                              ngroups = 1L,
                              nthresholds = NULL,
                              ov.names.x.block = NULL) {
  categorical <- FALSE

  ### tmp.default elements: parameters that are typically not specified by
  ###                   users, but should typically be considered,
  ###                   either free or fixed

  # extract `names' of various types of variables:
  lv.names <- lav_partable_vnames(FLAT, type = "lv") # latent variables
  # lv.names.r   <- lav_partable_vnames(FLAT, type="lv.regular")
  # regular latent variables
  if (composites) {
    lv.names.f <- character(0L)
    lv.names.c <- lav_partable_vnames(FLAT, type = "lv.composite")
    ov.ind.c <- lav_partable_vnames(FLAT, type = "ov.cind")
    lv.names.noc <- lv.names[!lv.names %in% lv.names.c]
  } else {
    lv.names.c <- character(0L)
    ov.ind.c <- character(0L)
    lv.names.f <- lav_partable_vnames(FLAT, type = "lv.formative")
    lv.names.noc <- lv.names
  }

  # formative latent variables
  ov.names <- lav_partable_vnames(FLAT, type = "ov")
  # observed variables
  ov.names.x <- lav_partable_vnames(FLAT, type = "ov.x")
  # exogenous x covariates
  lv.names.int <- lav_partable_vnames(FLAT, type = "lv.interaction")
  # lv interactions

  if (is.null(ov.names.x.block)) {
    ov.names.x.block <- ov.names.x
  }
  ov.names.nox <- lav_partable_vnames(FLAT, type = "ov.nox")
  lv.names.x <- lav_partable_vnames(FLAT, type = "lv.x") # exogenous lv
  ov.names.y <- lav_partable_vnames(FLAT, type = "ov.y") # dependent ov
  lv.names.y <- lav_partable_vnames(FLAT, type = "lv.y") # dependent lv
  lv.names.efa <- lav_partable_vnames(FLAT, type = "lv.efa")
  # lvov.names.y <- c(ov.names.y, lv.names.y)
  lvov.names.y <- c(lv.names.y, ov.names.y)

  # get 'ordered' variables, either from FLAT or varTable
  ov.names.ord1 <- lav_partable_vnames(FLAT, type = "ov.ord")
  # check if we have "|" for exogenous variables
  if (length(ov.names.ord1) > 0L) {
    idx <- which(ov.names.ord1 %in% ov.names.x)
    if (length(idx) > 0L) {
      lav_msg_warn(gettext("thresholds are defined for exogenous variables:"),
                   lav_msg_view(ov.names.ord1[idx], "none"))
    }
  }

  # check data
  if (!is.null(varTable)) {
    ov.names.ord2 <-
      as.character(varTable$name[varTable$type == "ordered"])
    # remove fixed.x variables
    idx <- which(ov.names.ord2 %in% ov.names.x)
    if (length(idx) > 0L) {
      ov.names.ord2 <- ov.names.ord2[-idx]
    }

    # remove those that do appear in the model syntax
    idx <- which(!ov.names.ord2 %in% ov.names)
    if (length(idx) > 0L) {
      ov.names.ord2 <- ov.names.ord2[-idx]
    }
  } else {
    ov.names.ord2 <- character(0L)
  }

  # check nthresholds, if it is a named vector
  ov.names.ord3 <- character(0L)
  if (!is.null(nthresholds)) {
    if (!is.null(varTable)) {
      lav_msg_stop(gettext(
        "the varTable and nthresholds arguments should not be used together."))
    }
    if (!is.numeric(nthresholds)) {
      lav_msg_stop(gettext("nthresholds should be a named vector of integers."))
    }
    nth.names <- names(nthresholds)
    if (!is.null(nth.names)) {
      ov.names.ord3 <- nth.names
    } else {
      # if nthresholds is just a number, all is good; otherwise it
      # should be a names vector
      if (length(nthresholds) > 1L) {
        lav_msg_warn(gettext("nthresholds must be a named vector of integers."))
      }
      # just a single number -> assume ALL y variables are ordered
      ov.names.ord3 <- ov.names.nox
    }
  }

  # final ov.names.ord
  tmp <- unique(c(ov.names.ord1, ov.names.ord2, ov.names.ord3))
  ov.names.ord <- ov.names[ov.names %in% tmp]

  # if we have the "|" in the model syntax, check the number of thresholds
  # if(!is.null(varTable) && length(ov.names.ord1) > 0L) {
  #    for(o in ov.names.ord1) {
  #        nth <- varTable$nlev[ varTable$name == o ] - 1L
  #        nth.in.partable <- sum(FLAT$op == "|" & FLAT$lhs == o)
  #        if(nth != nth.in.partable) {
  #            stop("lavaan ERROR: expected ", max(0,nth),
  #                 " threshold(s) for variable ",
  #                 sQuote(o), "; syntax contains ", nth.in.partable, "\n")
  #        }
  #    }
  # }

  if (length(ov.names.ord) > 0L) {
    categorical <- TRUE
  }

  # do we have any EFA lv's? they need special treatment if auto.efa = TRUE
  if (!is.null(FLAT$efa) && auto.efa) {
    lv.names.efa <- unique(FLAT$lhs[FLAT$op == "=~" &
      nchar(FLAT$efa) > 0L])
    # remove them from lv.names.x
    # if(length(lv.names.x) > 0L) {
    #    both.idx <- which(lv.names.x %in% lv.names.efa)
    #    if(length(both.idx) > 0L) {
    #        lv.names.x <- lv.names.x[ -both.idx ]
    #    }
    # }

    # remove them from lvov.names.y
    # if(length(lvov.names.y) > 0L) {
    #    both.idx <- which(lvov.names.y %in% lv.names.efa)
    #    if(length(both.idx) > 0L) {
    #        lvov.names.y <- lvov.names.y[ -both.idx ]
    #    }
    # }
  } else {
    lv.names.efa <- character(0)
  }

  lhs <- rhs <- character(0)

  # 1. THRESHOLDS (based on varTable)
  #    NOTE: - new in 0.5-18: ALWAYS include threshold parameters in partable,
  #            but only free them if auto.th = TRUE
  #          - [only ov.names.ord2, because ov.names.ord1 are already
  #            in tmp.user and we only need to add 'default' parameters here]
  #            (not any longer: we create them for ALL ordered var (0.6-12)
  nth <- 0L
  # if(auto.th && length(ov.names.ord2) > 0L) {
  # if(length(ov.names.ord2) > 0L) {
  if (length(ov.names.ord) > 0L) {
    # for(o in ov.names.ord2) {
    for (o in ov.names.ord) {
      if (!is.null(varTable)) {
        nth <- varTable$nlev[varTable$name == o] - 1L
      } else if (!is.null(nthresholds)) {
        if (length(nthresholds) == 1L && is.null(nth.names)) {
          nth <- nthresholds
        } else {
          # we can assume nthresholds is a named vector
          nth <- unname(nthresholds[o])
          if (is.na(nth)) {
            lav_msg_stop(gettextf("ordered variable %s not found in the
                                  named vector nthresholds.", o))
          }
        }
      }
      if (nth < 1L) next
      lhs <- c(lhs, rep(o, nth))
      rhs <- c(rhs, paste("t", seq_len(nth), sep = ""))
    }
    nth <- length(lhs)
  }

  # 2. default (residual) variances and covariances

  # a) (residual) VARIANCES (all ov's except exo, and all lv's)
  # NOTE: change since 0.5-17: we ALWAYS include the vars in the
  #       parameter table; but only if auto.var = TRUE, we set them free
  # if(auto.var) {
  ov.var <- ov.names.nox
  # auto-remove ordinal variables
  # idx <- match(ov.names.ord, ov.var)
  # if(length(idx)) ov.var <- ov.var[-idx]
  lhs <- c(lhs, ov.var, lv.names)
  rhs <- c(rhs, ov.var, lv.names)
  # }

  # b) `independent` latent variable COVARIANCES (lv.names.x)
  if (auto.cov.lv.x && length(lv.names.x) > 1L) {
    tmp <- utils::combn(lv.names.x, 2)
    lhs <- c(lhs, tmp[1, ]) # to fill upper.tri
    rhs <- c(rhs, tmp[2, ])
  }

  # c) `dependent` latent variables COVARIANCES (lv.y.idx + ov.y.lv.idx)
  if (auto.cov.y && length(lvov.names.y) > 1L) {
    tmp <- utils::combn(lvov.names.y, 2L)
    lhs <- c(lhs, tmp[1, ]) # to fill upper.tri
    rhs <- c(rhs, tmp[2, ])
  }

  # d) exogenous x covariates: VARIANCES + COVARIANCES
  if ((nx <- length(ov.names.x)) > 0L) {
    if (conditional.x) {
      # new in 0.6-12: we make a distinction between ov.names.x and
      # ov.names.x.block: we treat them 'separately' (with no covariances
      # among them)
      # but we add 'regressions' instead (see below)
      ov.names.x1 <- ov.names.x[!ov.names.x %in% ov.names.x.block]
      ov.names.x2 <- ov.names.x.block
      nx1 <- length(ov.names.x1) # splitted x
      nx2 <- length(ov.names.x2) # regular  x
      if (nx1 > 0L) {
        idx <- lower.tri(matrix(0, nx1, nx1), diag = TRUE)
        lhs <- c(lhs, rep(ov.names.x1, each = nx1)[idx]) # fill upper.tri
        rhs <- c(rhs, rep(ov.names.x1, times = nx1)[idx])
      }
      if (nx2 > 0L) {
        idx <- lower.tri(matrix(0, nx2, nx2), diag = TRUE)
        lhs <- c(lhs, rep(ov.names.x2, each = nx2)[idx]) # fill upper.tri
        rhs <- c(rhs, rep(ov.names.x2, times = nx2)[idx])
      }
    } else {
      idx <- lower.tri(matrix(0, nx, nx), diag = TRUE)
      lhs <- c(lhs, rep(ov.names.x, each = nx)[idx]) # fill upper.tri
      rhs <- c(rhs, rep(ov.names.x, times = nx)[idx])
    }
  }

  # e) indicators of composites: COVARIANCES
  #    but only within/intra blocks
  if ((ncx <- length(ov.ind.c)) > 0L) {
    # create W1
    W1 <- matrix(0, length(ov.ind.c), length(lv.names.c))
    c.idx <- which(FLAT$op == "<~")
    W1[cbind(match(FLAT$rhs[c.idx], ov.ind.c),
             match(FLAT$lhs[c.idx], lv.names.c))] <- 1
    W1W1 <- tcrossprod(W1)
    W1W1[upper.tri(W1W1, diag = TRUE)] <- 0 # keep lower.tri only
    if (ncx > 1L) {
      lhs <- c(lhs, ov.ind.c[col(W1W1)[as.logical(W1W1)]])
      rhs <- c(rhs, ov.ind.c[row(W1W1)[as.logical(W1W1)]])
    }
  }

  # f) efa latent variables COVARIANCES; only needed for 'mediators'
  #    (not in lv.names.x, not in lv.names.y) -- added in 0.6-18
  if (auto.efa && length(lv.names.efa) > 1L) {
    efa.values <- lav_partable_efa_values(FLAT)
    for (set in efa.values) {
      # correlated factors within each set
      this.set.lv <- unique(FLAT$lhs[FLAT$op == "=~" &
        !FLAT$lhs %in% lv.names.x &
        !FLAT$lhs %in% lv.names.y &
        FLAT$efa == set])
      if (length(this.set.lv) > 0L) {
        tmp <- utils::combn(this.set.lv, 2)
        lhs <- c(lhs, tmp[1, ]) # to fill upper.tri
        rhs <- c(rhs, tmp[2, ])
      }
    }
  }

  # create 'op' (thresholds come first, then variances)
  op <- rep("~~", length(lhs))
  op[seq_len(nth)] <- "|"

  # LATENT RESPONSE SCALES (DELTA)
  #    NOTE: - new in 0.5-19: ALWAYS include scaling parameters in partable,
  #            but only free them if auto.delta = TRUE (and parameterization
  #            is "delta"
  # if(auto.delta && auto.th && length(ov.names.ord) > 0L &&
  #   # length(lv.names) > 0L &&
  #   (ngroups > 1L || any(FLAT$op == "~*~") || parameterization == "theta")) {
  if (length(ov.names.ord) > 0L) {
    lhs <- c(lhs, ov.names.ord)
    rhs <- c(rhs, ov.names.ord)
    op <- c(op, rep("~*~", length(ov.names.ord)))
  }

  # same for correlation structures, but now for ALL variables
  if (!categorical && correlation) {
    lhs <- c(lhs, ov.names)
    rhs <- c(rhs, ov.names)
    op <- c(op, rep("~*~", length(ov.names)))
  }

  # 3. INTERCEPTS
  if (meanstructure) {
    # if(conditional.x) {
    #    ov.int <- ov.names.nox
    # } else {
    ov.int <- ov.names
    # }
    # auto-remove ordinal variables
    # idx <- which(ov.int %in% ov.names.ord)
    # if(length(idx)) ov.int <- ov.int[-idx]

    int.lhs <- c(ov.int, lv.names)
    lhs <- c(lhs, int.lhs)
    rhs <- c(rhs, rep("", length(int.lhs)))
    op <- c(op, rep("~1", length(int.lhs)))
  }

  # 4. REGRESSIONS
  if (conditional.x) {
    # new in 0.6-12: we make a distinction between ov.names.x and
    # ov.names.x.block: we treat them 'separately' (with no covariances
    # among them)
    # but we add 'regressions' instead!
    ov.names.x1 <- ov.names.x[!ov.names.x %in% ov.names.x.block]
    ov.names.x2 <- ov.names.x.block
    nx1 <- length(ov.names.x1) # splitted x
    nx2 <- length(ov.names.x2) # regular  x
    if (nx1 > 0L && nx2 > 0L) {
      # add regressions for splitted-x ~ regular-x
      lhs <- c(lhs, rep(ov.names.x1, times = nx2))
      op <- c(op, rep("~", nx2 * nx1))
      rhs <- c(rhs, rep(ov.names.x2, each = nx1))
    }
  }

  # free group weights
  if (group.w.free) {
    lhs <- c(lhs, "group")
    rhs <- c(rhs, "w")
    op <- c(op, "%")
  }

  tmp.default <- data.frame(
    lhs = lhs, op = op, rhs = rhs,
    mod.idx = rep(0L, length(lhs)),
    stringsAsFactors = FALSE
  )


  # 4. USER: user-specified elements
  lhs <- FLAT$lhs
  op <- FLAT$op
  rhs <- FLAT$rhs
  mod.idx <- FLAT$mod.idx

  lv.names <- lav_partable_vnames(FLAT, type = "lv") # latent variables
  ov.names <- lav_partable_vnames(FLAT, type = "ov") # observed variables
  tmp.user <- data.frame(
    lhs = lhs, op = op, rhs = rhs, mod.idx = mod.idx,
    stringsAsFactors = FALSE
  )

  # check for duplicated elements in tmp.user
  tmp.tmp <- tmp.user[, 1:3]
  idx <- which(duplicated(tmp.tmp))
  if (length(idx) > 0L) {
    txt <- sapply(seq_along(idx), function(i) {
      paste(
        "    ", tmp.tmp[idx[i], "lhs"],
        tmp.tmp[idx[i], "op"],
        tmp.tmp[idx[i], "rhs"]
      )
    })
    lav_msg_warn(gettext(
      "duplicated elements in model syntax have been ignored:"),
      lav_msg_view(txt, "none"))
    tmp.user <- tmp.user[-idx, ]
  }

  # check for duplicated elements in tmp.default
  # - FIXME: can we not avoid this somehow??
  # - for example, if the user model includes 'x1 ~~ x1'
  #   or 'x1 ~ 1'
  # - remove them from tmp.default
  tmp.tmp <- rbind(tmp.default[, 1:3], tmp.user[, 1:3])
  idx <- which(duplicated(tmp.tmp, fromLast = TRUE))
  # idx should be in tmp.default
  if (length(idx)) {
    for (i in idx) {
      flat.idx <- which(tmp.user$lhs == tmp.default$lhs[i] &
        tmp.user$op == tmp.default$op[i] &
        tmp.user$rhs == tmp.default$rhs[i])
      if (length(flat.idx) != 1L) {
        cat("[lavaan DEBUG] idx in tmp.tmp: i = ", i, "\n")
        print(tmp.tmp[i, ])
        cat("[lavaan DEBUG] idx in tmp.default: i = ", i, "\n")
        print(tmp.default[i, ])
        cat("[lavaan DEBUG] flat.idx:")
        print(flat.idx)
      }
    }
    tmp.default <- tmp.default[-idx, ]
  }

  # now that we have removed all duplicated elements, we can construct
  # the tmp.list for a single group/block
  lhs <- c(tmp.user$lhs, tmp.default$lhs)
  op <- c(tmp.user$op, tmp.default$op)
  rhs <- c(tmp.user$rhs, tmp.default$rhs)
  user <- c(
    rep(1L, length(tmp.user$lhs)),
    rep(0L, length(tmp.default$lhs))
  )
  mod.idx <- c(tmp.user$mod.idx, tmp.default$mod.idx)

  # by default: everyting is free!
  free <- rep(1L, length(lhs))
  ustart <- rep(as.numeric(NA), length(lhs))
  # label   <- paste(lhs, op, rhs, sep="")
  label <- rep(character(1), length(lhs))
  exo <- rep(0L, length(lhs))

  # 0a. if auto.th = FALSE, set fix the thresholds
  if (!auto.th) {
    th.idx <- which(op == "|" & user == 0L)
    free[th.idx] <- 0L
  }

  # 0b. if auto.var = FALSE, set the unspecified variances to zero
  if (!auto.var) {
    var.idx <- which(op == "~~" &
      lhs == rhs &
      !lhs %in% ov.ind.c &
      user == 0L)
    ustart[var.idx] <- 0.0
    free[var.idx] <- 0L
  } else if (length(lv.names.f) > 0L) {
    # 'formative' (residual) variances are set to zero by default
    var.idx <- which(op == "~~" &
      lhs == rhs &
      lhs %in% lv.names.f &
      user == 0L)
    ustart[var.idx] <- 0.0
    free[var.idx] <- 0L
  }

  # 0c. for the ~~ for composite indicators: currently ALWAYS fixed
  #     todo: create an option to free them anyway
  if (length(ov.ind.c) > 0) {
    var.idx <- which(op == "~~" & lhs %in% ov.ind.c)
    ustart[var.idx] <- as.numeric(NA)
    free[var.idx] <- 0L
  }

  # 0d. variances for composites: ALWAYS fixed (should be set later
  #     by lav_lisrel_composites_variances
  if (length(lv.names.c) > 0) {
    var.idx <- which(op == "~~" & lhs %in% lv.names.c & lhs == rhs)
    ustart[var.idx] <- as.numeric(NA)
    free[var.idx] <- 0L
  }


  # 1. fix metric of regular latent variables
  if (std.lv) {
    # fix metric by fixing the variance of the latent variable
    lv.var.idx <- which(op == "~~" &
      lhs %in% lv.names & lhs == rhs)
    ustart[lv.var.idx] <- 1.0
    free[lv.var.idx] <- 0L
  }
  if (auto.efa && length(lv.names.efa) > 0L) {
    # fix lv variances of efa blocks to unity
    lv.var.idx <- which(op == "~~" &
      lhs %in% lv.names.efa & lhs == rhs)
    ustart[lv.var.idx] <- 1.0
    free[lv.var.idx] <- 0L
  }
  if (auto.fix.first) {
    # fix metric by fixing the loading of the first indicator
    # (but not for efa factors)
    mm.idx <- which(op == "=~" & !(lhs %in% lv.names.efa))
    first.idx <- mm.idx[which(!duplicated(lhs[mm.idx]))]
    ustart[first.idx] <- 1.0
    free[first.idx] <- 0L
    if (composites && length(lv.names.c) > 0L) {
      mm.idx <- which(op == "<~")
      first.idx <- mm.idx[which(!duplicated(lhs[mm.idx]))]
      ustart[first.idx] <- 1.0
      free[first.idx] <- 0L
    }
  }

  # 2. fix residual variance of single indicators to zero
  if (auto.var && auto.fix.single) {
    mm.idx <- which(op == "=~")
    tmp.t <- table(lhs[mm.idx])
    if (any(tmp.t == 1L)) {
      # ok, we have a LV with only a single indicator
      lv.names.single <- names(tmp.t)[tmp.t == 1L]
      # get corresponding indicator if unique
      lhs.mm <- lhs[mm.idx]
      rhs.mm <- rhs[mm.idx]
      single.ind <- rhs.mm[which(lhs.mm %in% lv.names.single &
        lhs.mm != rhs.mm & # exclude phantom
        !(duplicated(rhs.mm) |
          duplicated(rhs.mm, fromLast = TRUE)))]
      # is the indicator unique?
      if (length(single.ind) > 0L) {
        var.idx <- which(op == "~~" & lhs %in% single.ind &
          rhs %in% single.ind &
          lhs == rhs &
          user == 0L)
        ustart[var.idx] <- 0.0
        free[var.idx] <- 0L
      }
    }
  }

  # 3. orthogonal = TRUE?
  if (orthogonal) {
    lv.cov.idx <- which(op == "~~" &
      lhs %in% lv.names &
      rhs %in% lv.names &
      lhs != rhs &
      user == 0L)
    ustart[lv.cov.idx] <- 0.0
    free[lv.cov.idx] <- 0L
  }
  # 3b. orthogonal.y = TRUE?
  if (orthogonal.y) {
    lv.cov.idx <- which(op == "~~" &
      lhs %in% lv.names.y &
      rhs %in% lv.names.y &
      lhs != rhs &
      user == 0L)
    ustart[lv.cov.idx] <- 0.0
    free[lv.cov.idx] <- 0L
  }
  # 3c. orthogonal.x = TRUE?
  if (orthogonal.x) {
    lv.cov.idx <- which(op == "~~" &
      lhs %in% lv.names.x &
      rhs %in% lv.names.x &
      lhs != rhs &
      user == 0L)
    ustart[lv.cov.idx] <- 0.0
    free[lv.cov.idx] <- 0L
  }
  # 3d. orthogonal.efa = TRUE?
  if (orthogonal.efa) {
    lv.cov.idx <- which(op == "~~" &
      lhs %in% lv.names.efa &
      rhs %in% lv.names.efa &
      lhs != rhs &
      user == 0L)
    ustart[lv.cov.idx] <- 0.0
    free[lv.cov.idx] <- 0L
  }

  # 4. intercepts
  if (meanstructure) {
    if (categorical) {
      # zero intercepts/means ordinal variables
      ov.int.idx <- which(op == "~1" &
        lhs %in% ov.names.ord &
        user == 0L)
      ustart[ov.int.idx] <- 0.0
      free[ov.int.idx] <- 0L
    }
    if (int.ov.free == FALSE) {
      # zero intercepts/means observed variables
      ov.int.idx <- which(op == "~1" &
        lhs %in% ov.names &
        user == 0L)
      ustart[ov.int.idx] <- 0.0
      free[ov.int.idx] <- 0L
    }
    if (int.lv.free == FALSE) {
      # zero intercepts/means latent variables
      lv.int.idx <- which(op == "~1" &
        lhs %in% lv.names &
        user == 0L)
      ustart[lv.int.idx] <- 0.0
      free[lv.int.idx] <- 0L
    }
    # 4b. fixed effect (only if we have random slopes)
    if (!is.null(FLAT$rv) && any(nchar(FLAT$rv) > 0L)) {
      lv.names.rv <- lav_partable_vnames(FLAT, "lv.rv")
      lv.rv.idx <- which(op == "~1" &
        lhs %in% lv.names.rv &
        user == 0L)
      ustart[lv.rv.idx] <- as.numeric(NA)
      free[lv.rv.idx] <- 1L
    }
    if (length(lv.names.int) > 0L) {
      lv.int.idx <- which(op == "~1" &
        lhs %in% lv.names.int &
        user == 0L)
      ustart[lv.int.idx] <- as.numeric(NA)
      free[lv.int.idx] <- 1L
    }
    # composites: always non-free, but with ustart = NA; value should be
    # filled in later as a function of the other parameters
    if (length(lv.names.c) > 0L) {
      c.int.idx <- which(op == "~1" & lhs %in% lv.names.c & user == 0L)
      ustart[c.int.idx] <- as.numeric(NA)
      free[c.int.idx] <- 0L
    }
  }

  # 4b. fixed effect (only if we have random slopes)
  # if(!is.null(FLAT$rv)) {
  #    }

  # 5. handle exogenous `x' covariates
  # usually, ov.names.x.block == ov.names.x
  # except if multilevel, where 'splitted' ov.x are treated as endogenous

  # 5a conditional.x = FALSE
  if (!conditional.x && fixed.x && length(ov.names.x.block) > 0) {
    # 1. variances/covariances
    exo.var.idx <- which(op == "~~" &
      rhs %in% ov.names.x.block &
      lhs %in% ov.names.x.block &
      user == 0L)
    ustart[exo.var.idx] <- as.numeric(NA) # should be overriden later!
    free[exo.var.idx] <- 0L
    exo[exo.var.idx] <- 1L

    # 2. intercepts
    exo.int.idx <- which(op == "~1" &
      lhs %in% ov.names.x.block &
      user == 0L)
    ustart[exo.int.idx] <- as.numeric(NA) # should be overriden later!
    free[exo.int.idx] <- 0L
    exo[exo.int.idx] <- 1L
  }

  # 5a-bis. conditional.x = TRUE
  if (conditional.x && length(ov.names.x) > 0L) {
    # 1. variances/covariances
    exo.var.idx <- which(op == "~~" &
      rhs %in% ov.names.x &
      lhs %in% ov.names.x &
      user == 0L)
    if (fixed.x) {
      ustart[exo.var.idx] <- as.numeric(NA) # should be overriden later!
      free[exo.var.idx] <- 0L
    }
    exo[exo.var.idx] <- 1L

    # 2. intercepts
    exo.int.idx <- which(op == "~1" &
      lhs %in% ov.names.x &
      user == 0L)
    if (fixed.x) {
      ustart[exo.int.idx] <- as.numeric(NA) # should be overriden later!
      free[exo.int.idx] <- 0L
    }
    exo[exo.int.idx] <- 1L

    # 3. regressions ov + lv
    exo.reg.idx <- which(op %in% c("~", "<~") &
      lhs %in% c(lv.names, ov.names.nox) &
      rhs %in% ov.names.x)
    exo[exo.reg.idx] <- 1L

    # 3b regression splitted.x ~ regular.x
    exo.reg2.idx <- which(op %in% c("~", "<~") &
      lhs %in% ov.names.x &
      rhs %in% ov.names.x)
    if (fixed.x) {
      ustart[exo.reg2.idx] <- as.numeric(NA) # should be overriden later!
      free[exo.reg2.idx] <- 0L
    }
    exo[exo.reg2.idx] <- 1L
  }

  # 5b. residual variances of ordinal variables?
  if (length(ov.names.ord) > 0L) {
    ord.idx <- which(lhs %in% ov.names.ord &
      op == "~~" &
      user == 0L & ## New in 0.6-1
      lhs == rhs)
    ustart[ord.idx] <- 1L ## FIXME!! or 0?? (0 breaks ex3.12)
    free[ord.idx] <- 0L
  }

  # 5c latent response scales of ordinal variables?
  #    by default, all fixed to 1.0
  if (length(ov.names.ord) > 0L) {
    delta.idx <- which(op == "~*~" &
      user == 0L) ## New in 0.6-1
    ustart[delta.idx] <- 1.0
    free[delta.idx] <- 0L
  }

  # correlation structure (new in 0.6-13)
  if (correlation) {
    var.idx <- which(lhs %in% ov.names &
      op == "~~" &
      user == 0L &
      lhs == rhs)
    ustart[var.idx] <- 1L
    free[var.idx] <- 0L

    delta.idx <- which(op == "~*~" &
      user == 0L)
    ustart[delta.idx] <- 1.0
    free[delta.idx] <- 0L
  }

  # group proportions (group 1L)
  if (group.w.free) {
    group.idx <- which(lhs == "group" & op == "%")
    # if(ngroups > 1L) {
    free[group.idx] <- 1L
    ustart[group.idx] <- as.numeric(NA)
    # } else {
    #      free[ group.idx ] <- 0L
    #    ustart[ group.idx ] <- 0.0 # last group
    # }
  }

  # 6. multiple groups?
  group <- rep(1L, length(lhs))
  if (ngroups > 1) {

    # only if "loadings" in group.equal and !std.lv:
    # construct tempory tmp.list to obtain lv.marker
    if (!std.lv & "loadings" %in% group.equal) {
      tmp.list <- list(
        id          = seq_along(lhs),
        lhs         = lhs,
        op          = op,
        rhs         = rhs,
        free        = free,
        ustart      = ustart,
        block       = rep(1, length(rhs)))
      lv.marker <- lav_partable_vnames(tmp.list, "lv.marker")
    }


    group <- rep(1:ngroups, each = length(lhs))
    user <- rep(user, times = ngroups)
    lhs <- rep(lhs, times = ngroups)
    op <- rep(op, times = ngroups)
    rhs <- rep(rhs, times = ngroups)
    free <- rep(free, times = ngroups)
    ustart <- rep(ustart, times = ngroups)
    mod.idx <- rep(mod.idx, times = ngroups)
    label <- rep(label, times = ngroups)
    exo <- rep(exo, times = ngroups)

    # specific changes per group
    for (g in 2:ngroups) {
      # free/fix intercepts latent variables
      if (meanstructure) {
        int.idx <- which(op == "~1" &
          lhs %in% lv.names.noc &
          user == 0L &
          group == g)
        if (int.lv.free == FALSE && g > 1 &&
          ("intercepts" %in% group.equal) &&
          !("means" %in% group.equal)) {
          free[int.idx] <- 1L
          ustart[int.idx] <- as.numeric(NA)
        }
      }

      # free intercept indicators if equal thresholds (new in 0.6-20)
      if (meanstructure && length(ov.names.ord) > 0L) {
        ord.idx <- which(op == "~1" &
          lhs %in% ov.names.ord &
          user == 0L &
          group == g)
        if (int.lv.free == FALSE && g > 1 &&
           "thresholds" %in% group.equal) {
          free[ord.idx] <- 1L
          ustart[ord.idx] <- as.numeric(NA)
        }
      }

      # latent variances if std.lv = TRUE (new in 0.6-4)
      if (std.lv && "loadings" %in% group.equal &&
        !"lv.variances" %in% group.equal) {
        lv.var.idx <- which(op == "~~" &
          lhs %in% lv.names &
          !lhs %in% lv.names.efa &
          lhs == rhs &
          user == 0L &
          group == g)
        if (length(lv.var.idx) > 0L) {
          free[lv.var.idx] <- 1L
          ustart[lv.var.idx] <- as.numeric(NA)
        }
      # marker indicator if std.lv = FALSE (new in 0.6-20)
      } else if(!std.lv && "loadings" %in% group.equal) {
        marker.idx <- which(op == "=~" &
          rhs %in% lv.marker &
          free == 0L &
          ustart == 1L &
          group == g)
        if (length(marker.idx) > 0L) {
          free[marker.idx] <- 1L
          ustart[marker.idx] <- as.numeric(NA)
        }
      }

      # latent variances if efa = TRUE (new in 0.6-5)
      if (length(lv.names.efa) > 0L &&
          auto.efa && "loadings" %in% group.equal &&
        !"lv.variances" %in% group.equal) {
        lv.var.idx <- which(op == "~~" &
          lhs %in% lv.names.efa &
          lhs == rhs &
          user == 0L &
          group == g)
        if (length(lv.var.idx) > 0L) {
          free[lv.var.idx] <- 1L
          ustart[lv.var.idx] <- as.numeric(NA)
        }
      }

      # latent response scaling -- categorical only
      # - if thresholds are equal -> free scalings/residual variances
      # - but not for binary indicators!
      if (length(ov.names.ord) > 0L) {
        nth <- sapply(ov.names.ord,
          function(x) sum(lhs == x & op == "|" & group == 1L))
        ov.names.ord.notbinary <- ov.names.ord[nth > 1L]
        if (auto.delta && parameterization == "delta") {
          if (any(op == "~*~" & group == g) &&
            ("thresholds" %in% group.equal)) {
            delta.idx <- which(op == "~*~" & group == g &
              lhs %in% ov.names.ord.notbinary)
            free[delta.idx] <- 1L
            ustart[delta.idx] <- as.numeric(NA)
          }
        } else if (parameterization == "theta") {
          if (any(op == "~*~" & group == g) &&
            ("thresholds" %in% group.equal)) {
            var.ord.idx <- which(op == "~~" & group == g &
              lhs %in% ov.names.ord.notbinary & lhs == rhs)
            free[var.ord.idx] <- 1L
            ustart[var.ord.idx] <- as.numeric(NA)
          }
        }
      }

      # group proportions
      if (group.w.free) {
        group.idx <- which(lhs == "group" & op == "%" & group == g)
        # if(g == ngroups) {
        #      free[ group.idx ] <- 0L
        #    ustart[ group.idx ] <- 0.0 # last group
        # } else {
        free[group.idx] <- 1L
        ustart[group.idx] <- as.numeric(NA)
        # }
      }
    } # g
  } # ngroups

  # construct tmp.list
  tmp.list <- list(
    id          = seq_along(lhs),
    lhs         = lhs,
    op          = op,
    rhs         = rhs,
    user        = user
  )

  # add block column (before group/level columns)
  if (!is.null(block.id)) {
    # only one block
    tmp.list$block <- rep(block.id, length(lhs))
  } else {
    # block is a combination of at least group, level, ...
    # for now, only group
    tmp.list$block <- group
  }

  # block columns (typically only group)
  for (block in blocks) {
    if (block == "group") {
      tmp.list[[block]] <- group
    } else {
      tmp.list[[block]] <- rep(0L, length(lhs))
    }
  }

  # other columns
  tmp.list2 <- list(
    mod.idx     = mod.idx,
    free        = free,
    ustart      = ustart,
    exo         = exo,
    label       = label
  )

  tmp.list <- c(tmp.list, tmp.list2)
}

# univariate modification indices
#

modindices <- function(object,
                       standardized = TRUE,
                       cov.std = TRUE,
                       information = "expected",
                       # power statistics?
                       power = FALSE,
                       delta = 0.1,
                       alpha = 0.05,
                       high.power = 0.75,
                       # customize output
                       sort. = FALSE,
                       minimum.value = 0.0,
                       maximum.number = nrow(LIST),
                       free.remove = TRUE,
                       na.remove = TRUE,
                       op = NULL) {
  # check object
  object <- lav_object_check_version(object)

  # check if model has converged
  if (object@optim$npar > 0L && !object@optim$converged) {
    lav_msg_warn(gettext("model did not converge"))
  }

  # not ready for estimator = "PML"
  if (object@Options$estimator == "PML") {
    lav_msg_stop(gettext(
      "modification indices for estimator PML are not implemented yet."))
  }

  # new in 0.6-17: check if the model contains equality constraints
  if (object@Model@eq.constraints) {
    lav_msg_warn(
      gettext("the modindices() function ignores equality constraints;
              use lavTestScore() to assess the impact of releasing one or
              multiple constraints.")
    )
  }

  # sanity check
  if (power) {
    standardized <- TRUE
  }

  # extended list (fixed-to-zero parameters)
  strict.exo <- FALSE
  if (object@Model@conditional.x) {
    strict.exo <- TRUE
  }
  FULL <- lav_partable_full(
    partable = lav_partable_set_cache(object@ParTable, object@pta),
    free = TRUE, start = TRUE,
    strict.exo = strict.exo
  )
  FULL$free <- rep(1L, nrow(FULL))
  FULL$user <- rep(10L, nrow(FULL))

  FIT <- lav_object_extended(object, add = FULL, all.free = TRUE)
  LIST <- FIT@ParTable


  # compute information matrix 'extended model'
  # ALWAYS use *expected* information (for now)
  Information <- lavTech(FIT, paste("information", information, sep = "."))

  # compute gradient 'extended model'
  score <- lavTech(FIT, "gradient.logl")

  # Saris, Satorra & Sorbom 1987
  # partition Q into Q_11, Q_22 and Q_12/Q_21
  # which elements of Q correspond with 'free' and 'nonfree' parameters?
  model.idx <- LIST$free[LIST$free > 0L & LIST$user != 10L]
  extra.idx <- LIST$free[LIST$free > 0L & LIST$user == 10L]

  # catch empty extra.idx (no modification indices!)
  if (length(extra.idx) == 0L) {
    # 2 possibilities: either model is saturated, or we have constraints
    if (object@test[[1]]$df == 0) {
      lav_msg_warn(gettext(
        "list with extra parameters is empty; model is saturated"))
    } else {
      lav_msg_warn(gettext(
        "list with extra parameters is empty; to release equality
        constraints, use lavTestScore()"))
    }
    LIST <- data.frame(
      lhs = character(0), op = character(0),
      rhs = character(0), group = integer(0),
      mi = numeric(0), epc = numeric(0),
      sepc.lv = numeric(0), sepc.all = numeric(0),
      sepc.nox = numeric(0)
    )
    return(LIST)
  }

  # partition
  I11 <- Information[extra.idx, extra.idx, drop = FALSE]
  I12 <- Information[extra.idx, model.idx, drop = FALSE]
  I21 <- Information[model.idx, extra.idx, drop = FALSE]
  I22 <- Information[model.idx, model.idx, drop = FALSE]

  # ALWAYS use *expected* information (for now)
  I22.inv <- try(
    lavTech(object, paste("inverted.information",
      information,
      sep = "."
    )),
    silent = TRUE
  )
  # just in case...
  if (inherits(I22.inv, "try-error")) {
    lav_msg_stop(gettext(
      "could not compute modification indices; information matrix is singular"))
  }

  V <- I11 - I12 %*% I22.inv %*% I21
  V.diag <- diag(V)
  # dirty hack: catch very small or negative values in diag(V)
  # this is needed eg when parameters are not identified if freed-up;
  idx <- which(V.diag < .Machine$double.eps^(1 / 3)) # was 1/2 <0.6-14
  if (length(idx) > 0L) {
    V.diag[idx] <- as.numeric(NA)
  }

  # create and fill in mi
  if (object@Data@nlevels == 1L) {
    N <- object@SampleStats@ntotal
    #if (object@Model@estimator %in% ("ML")) {
      score <- -1 * score # due to gradient.logl
    #}
  } else {
    # total number of clusters (over groups)
    N <- 0
    for (g in 1:object@SampleStats@ngroups) {
      N <- N + object@Data@Lp[[g]]$nclusters[[2]]
    }
    # score <- score * (2 * object@SampleStats@ntotal) / N
    score <- score / 2 # -2 * LRT
  }
  mi <- numeric(length(score))
  mi[extra.idx] <- N * (score[extra.idx] * score[extra.idx]) / V.diag
  if (length(model.idx) > 0L) {
    mi[model.idx] <- N * (score[model.idx] * score[model.idx]) / diag(I22)
  }

  LIST$mi <- rep(as.numeric(NA), length(LIST$lhs))
  LIST$mi[LIST$free > 0] <- mi

  # handle equality constraints (if any)
  # eq.idx <- which(LIST$op == "==")
  # if(length(eq.idx) > 0L) {
  #    OUT <- lavTestScore(object, warn = FALSE)
  #    LIST$mi[ eq.idx ] <- OUT$uni$X2
  # }

  # scaled?
  # if(length(object@test) > 1L) {
  #    LIST$mi.scaled <- LIST$mi / object@test[[2]]$scaling.factor
  # }

  # EPC
  d <- (-1 * N) * score
  # needed? probably not; just in case
  d[which(abs(d) < 1e-15)] <- 1.0
  LIST$epc[LIST$free > 0] <- mi / d


  # standardize?
  if (standardized) {
    EPC <- LIST$epc

    if (cov.std) {
      # replace epc values for variances by est values
      var.idx <- which(LIST$op == "~~" & LIST$lhs == LIST$rhs &
        LIST$exo == 0L)
      EPC[var.idx] <- LIST$est[var.idx]
    }

    # two problems:
    #   - EPC of variances can be negative, and that is
    #     perfectly legal
    #   - EPC (of variances) can be tiny (near-zero), and we should
    #     not divide by tiny variables
    small.idx <- which(LIST$op == "~~" &
      LIST$lhs == LIST$rhs &
      abs(EPC) < sqrt(.Machine$double.eps))
    if (length(small.idx) > 0L) {
      EPC[small.idx] <- as.numeric(NA)
    }

    # get the sign
    EPC.sign <- sign(LIST$epc)

    LIST$sepc.lv <- EPC.sign * lav_standardize_lv(object,
      partable = LIST,
      est = abs(EPC),
      cov.std = cov.std
    )
    if (length(small.idx) > 0L) {
      LIST$sepc.lv[small.idx] <- 0
    }
    LIST$sepc.all <- EPC.sign * lav_standardize_all(object,
      partable = LIST,
      est = abs(EPC),
      cov.std = cov.std
    )
    if (length(small.idx) > 0L) {
      LIST$sepc.all[small.idx] <- 0
    }
    LIST$sepc.nox <- EPC.sign * lav_standardize_all_nox(object,
      partable = LIST,
      est = abs(EPC),
      cov.std = cov.std
    )
    if (length(small.idx) > 0L) {
      LIST$sepc.nox[small.idx] <- 0
    }
  }

  # power?
  if (power) {
    LIST$delta <- delta
    # FIXME: this is using epc in unstandardized metric
    #        this would be much more useful in standardized metric
    #        we need a lav_standardize_all.reverse function...
    LIST$ncp <- (LIST$mi / (LIST$epc * LIST$epc)) * (delta * delta)
    LIST$power <- 1 - pchisq(qchisq((1.0 - alpha), df = 1),
      df = 1, ncp = LIST$ncp
    )
    LIST$decision <- character(length(LIST$power))

    # five possibilities (Table 6 in Saris, Satorra, van der Veld, 2009)
    mi.significant <- ifelse(1 - pchisq(LIST$mi, df = 1) < alpha,
      TRUE, FALSE
    )
    high.power <- LIST$power > high.power
    # FIXME: sepc.all or epc??
    # epc.high <- abs(LIST$sepc.all) > LIST$delta
    epc.high <- abs(LIST$epc) > LIST$delta

    LIST$decision[which(!mi.significant & !high.power)] <- "(i)"
    LIST$decision[which(mi.significant & !high.power)] <- "**(m)**"
    LIST$decision[which(!mi.significant & high.power)] <- "(nm)"
    LIST$decision[which(mi.significant & high.power &
      !epc.high)] <- "epc:nm"
    LIST$decision[which(mi.significant & high.power &
      epc.high)] <- "*epc:m*"

    # LIST$decision[ which(mi.significant &  high.power) ] <- "epc"
    # LIST$decision[ which(mi.significant & !high.power) ] <- "***"
    # LIST$decision[ which(!mi.significant & !high.power) ] <- "(i)"
  }

  # remove rows corresponding to 'fixed.x' exogenous parameters
  # exo.idx <- which(LIST$exo == 1L & nchar(LIST$plabel) > 0L)
  # if(length(exo.idx) > 0L) {
  #    LIST <- LIST[-exo.idx,]
  # }

  # remove some columns
  LIST$id <- LIST$ustart <- LIST$exo <- LIST$label <- LIST$plabel <- NULL
  LIST$start <- LIST$free <- LIST$est <- LIST$se <- LIST$prior <- NULL
  LIST$upper <- LIST$lower <- NULL

  if (power) {
    LIST$sepc.lv <- LIST$sepc.nox <- NULL
  }

  # create data.frame
  LIST <- as.data.frame(LIST, stringsAsFactors = FALSE)
  class(LIST) <- c("lavaan.data.frame", "data.frame")

  # remove rows corresponding to 'old' free parameters
  if (free.remove) {
    old.idx <- which(LIST$user != 10L)
    if (length(old.idx) > 0L) {
      LIST <- LIST[-old.idx, ]
    }
  }

  # remove rows corresponding to 'equality' constraints
  eq.idx <- which(LIST$op == "==")
  if (length(eq.idx) > 0L) {
    LIST <- LIST[-eq.idx, ]
  }

  # remove even more columns
  LIST$user <- NULL

  # remove block/group/level is only single block
  if (lav_partable_nblocks(LIST) == 1L) {
    LIST$block <- NULL
    LIST$group <- NULL
    LIST$level <- NULL
  }

  # sort?
  if (sort.) {
    LIST <- LIST[order(LIST$mi, decreasing = TRUE), ]
  }
  if (minimum.value > 0.0) {
    LIST <- LIST[!is.na(LIST$mi) & LIST$mi > minimum.value, ]
  }
  if (maximum.number < nrow(LIST)) {
    LIST <- LIST[seq_len(maximum.number), ]
  }
  if (na.remove) {
    idx <- which(is.na(LIST$mi))
    if (length(idx) > 0) {
      LIST <- LIST[-idx, ]
    }
  }
  if (!is.null(op)) {
    idx <- LIST$op %in% op
    if (length(idx) > 0) {
      LIST <- LIST[idx, ]
    }
  }

  # add header
  # TODO: small explanation of the columns in the header?
  #    attr(LIST, "header") <-
  # c("modification indices for newly added parameters only; to\n",
  #   "see the effects of releasing equality constraints, use the\n",
  #   "lavTestScore() function")

  LIST
}

# aliases
modificationIndices <- modificationindices <- modindices

# IV/MIIV estimation

# internal function to be used inside lav_optim_noniter
# return 'x', the estimated vector of free parameters
lav_sem_miiv_internal <- function(lavmodel = NULL, lavh1 = NULL,
                                  lavsamplestats = NULL,
                                  lavpartable = NULL,
                                  lavdata = NULL, lavoptions = NULL) {
  # IV options
  iv.method <- toupper(lavoptions$estimator.args$iv.method)
  stopifnot(iv.method %in% "2SLS")
  iv.varcov.method <- toupper(lavoptions$estimator.args$iv.varcov.method)
  iv.samplestats <- lavoptions$estimator.args$iv.samplestats
  # just in case
  if (lavmodel@categorical) {
    iv.samplestats <- TRUE
  }
  stopifnot(iv.varcov.method %in% c("ULS", "GLS", "2RLS", "RLS"))

  # get lavpta
  lavpta <- lav_partable_attributes(lavpartable)

  # we assume the blocks are independent groups for now
  stopifnot(lavdata@nlevels == 1L)

  # directed versus undirected (free) parameters
  undirected.idx <- which(lavpartable$free > 0L &
    !duplicated(lavpartable$free) & # if ceq.simple
    lavpartable$op == "~~")
  directed.idx <- which(lavpartable$free > 0L &
    !duplicated(lavpartable$free) & # if ceq.simple
    !lavpartable$op %in% c("~~", "~*~"))
  free.directed.idx <- unique(lavpartable$free[directed.idx])
  free.undirected.idx <- unique(lavpartable$free[undirected.idx])

  # find ALL model-implied instrumental variables (miivs) per equation
  eqs <- lav_model_find_iv(lavmodel = lavmodel, lavpta = lavpta)

  # parameter vector -> all NA (for the free parameters)
  x <- lav_model_get_parameters(lavmodel) * as.numeric(NA)

  ########################################
  # first stage: directed parameter only #
  ########################################
  theta1 <- numeric(0L)
  if (length(free.directed.idx) > 0L) {
    if (iv.samplestats) {
      theta1 <- lav_sem_miiv_2sls_samplestats(
        eqs = eqs,
        lavmodel = lavmodel, lavpartable = lavpartable,
        lavdata = lavdata, lavsamplestats = lavsamplestats,
        lavh1 = lavh1, free.directed.idx = free.directed.idx
      )
    } else {
      theta1 <- lav_sem_miiv_2sls(
        eqs = eqs,
        lavmodel = lavmodel, lavpartable = lavpartable,
        lavdata = lavdata, free.directed.idx = free.directed.idx
      )
    }
    # update equations
    eqs <- attr(theta1, "eqs")
    theta1 <- as.numeric(theta1) # drop attributes
    # store theta1 elements in x
    x[free.directed.idx] <- theta1
  }

  #######################################
  # second stage: undirected parameters #
  #######################################

  # compute theta2 using ULS/GLS/RLS/2RLS
  theta2 <- numeric(0L)
  if (length(free.undirected.idx) > 0L) {
    theta2 <- lav_sem_miiv_varcov(
      x = theta1,
      lavmodel = lavmodel, lavpartable = lavpartable,
      lavh1 = lavh1, free.directed.idx = free.directed.idx,
      free.undirected.idx = free.undirected.idx,
      iv.varcov.method = iv.varcov.method
    )
    # store theta2 elements in x
    x[free.undirected.idx] <- theta2
  }

  attr(x, "eqs") <- eqs
  x
}


# stage 1: use 2SLS to find the regression coefficients of all
#          directed effects in the model -- continous/raw-data version
lav_sem_miiv_2sls <- function(eqs = NULL, lavmodel = NULL, lavpartable = NULL,
                              lavdata = NULL, free.directed.idx = NULL) {
  # this function is for continuous/raw-data only
  stopifnot(lavdata@data.type == "full")
  stopifnot(!lavmodel@categorical)

  # get lavpta
  lavpta <- lav_partable_attributes(lavpartable)

  if (is.null(eqs)) {
    # find ALL model-implied instrumental variables (miivs) per equation
    eqs <- lav_model_find_iv(lavmodel = lavmodel, lavpta = lavpta)
  }

  # number of blocks
  nblocks <- lavmodel@nblocks

  # parameter vector -> all NA (for the free parameters)
  x <- lav_model_get_parameters(lavmodel) * as.numeric(NA)

  # 2SLS per equation
  # for now: - no equality constraints (yet)
  #          - only OLS (not robust, no lasso, ...)
  for (b in seq_len(nblocks)) {
    # ov.names for this block
    ov.names <- lavpta$vnames$ov[[b]]

    # raw data for this block
    XY <- lavdata@X[[b]]

    # estimation per equation
    for (j in seq_along(eqs[[b]])) {
      # this equation
      eq <- eqs[[b]][[j]]

      # iv_flag?
      iv_flag <- TRUE
      if (!is.null(eq$iv_flag)) {
        iv_flag <- eq$iv_flag
      } else {
        # if rhs_new matches miiv, iv_flag is FALSE
        if (identical(eq$rhs_new, eq$miiv)) {
          iv_flag <- FALSE
        }
      }

      # Y: there is always an y variable
      y.idx <- match(eq$lhs_new, ov.names)
      yvec <- XY[, y.idx, drop = TRUE] # y-variable (always scalar)

      # X: usually, there are x variables (apart from the "1")
      if (identical(eq$rhs_new, "1")) {
        x.idx <- integer(0L)
        xmat <- matrix(0, nrow = nrow(XY), ncol = 0L)
      } else {
        x.idx <- match(eq$rhs_new, ov.names)
        xmat <- XY[, x.idx, drop = FALSE]
      }

      # Z: instruments
      if (iv_flag) {
        i.idx <- match(eq$miiv, ov.names)
        imat <- cbind(1, XY[, i.idx, drop = FALSE]) # instruments
      }

      # weights
      weights <- lavdata@weights[[b]]

      # sargan vector
      sargan <- rep(as.numeric(NA), 3L)
      names(sargan) <- c("stat", "df", "pvalue")

      # 0. check
      if (iv_flag && length(eq$miiv) < length(eq$rhs)) {
        # what to do? skip, or proceed anyway?
        eqs[[b]][[j]]$coef <- numeric(0L)
        eqs[[b]][[j]]$nobs <- nrow(xmat)
        eqs[[b]][[j]]$df_res <- as.integer(NA)
        eqs[[b]][[j]]$resvar <- as.numeric(NA)
        eqs[[b]][[j]]$resvar_df_res <- as.numeric(NA)
        eqs[[b]][[j]]$XX <- crossprod(cbind(1, xmat))
        eqs[[b]][[j]]$vcov <- matrix(0, 0L, 0L)
        eqs[[b]][[j]]$sargan <- sargan
        next
      }

      # 1. regress x on instruments
      if (iv_flag) {
        if (is.null(weights)) {
          fit_x_on_z <- lm.fit(x = imat, y = xmat)
        } else {
          fit_x_on_z <- lm.wfit(x = imat, y = xmat, weights = weights)
        }
        # check for NA's
        if (anyNA(fit_x_on_z$coefficients)) {
          lav_msg_warn(gettextf(
            "regression %s on %s failed (NAs);
                                 redundant instruments?",
            paste(ov.names[x.idx], collapse = " + "),
            paste(ov.names[i.idx], collapse = " + ")
          ))
        }
        xhat <- as.matrix(fit_x_on_z$fitted.values)
      } else {
        # just plain regression: x == xhat
        xhat <- xmat
      }

      # 2. regress y on xhat
      if (is.null(weights)) {
        fit_y_on_xhat <- lm.fit(x = cbind(1, xhat), y = yvec)
      } else {
        fit_y_on_xhat <- lm.wfit(
          x = cbind(1, xhat), y = yvec,
          weights = weights
        )
      }

      # 3. fill estimates in x
      # - eq$pt contains partable/user rows
      # - lavpartable$free[eq$pt] should give the free idx
      free.idx <- lavpartable$free[eq$pt]
      if (length(x.idx) > 0L) {
        if (all(free.idx > 0L)) {
          x[free.idx] <- fit_y_on_xhat$coefficients[-1]
        } else {
          # remove non-free elements
          zero.idx <- which(free.idx == 0L)
          free.idx <- free.idx[-zero.idx]
          if (length(free.idx) > 0) {
            x[free.idx] <- fit_y_on_xhat$coefficients[-1][-zero.idx]
          }
        }
      }
      if (lavmodel@meanstructure) {
        free.int.idx <- lavpartable$free[eq$ptint]
        if (free.int.idx > 0L) {
          x[free.int.idx] <- fit_y_on_xhat$coefficients[1]
        }
      }

      # 4. resvar
      notna.idx <- unname(which(!is.na(fit_y_on_xhat$coefficients)))
      ycoef <- fit_y_on_xhat$coefficients[notna.idx]
      res <- yvec - drop(cbind(1, xmat)[, notna.idx, drop = FALSE] %*% ycoef)
      df_res <- fit_y_on_xhat$df.residual
      if (is.null(weights)) {
        sse <- sum(res * res)
      } else {
        sse <- sum(weights * res * res)
      }
      resvar_df_res <- sse / df_res # what we should do...
      resvar <- sse / length(res)

      # 5. naive cov (for standard errors) (see summary.lm in base R)
      p1 <- 1L:fit_y_on_xhat$rank
      R <- chol2inv(fit_y_on_xhat$qr$qr[p1, p1, drop = FALSE])
      vcov <- R * resvar # scaled (for now)

      # 6. Sargan test (see summary.ivreg.R 363--371)
      if (iv_flag) {
        sargan["df"] <- length(i.idx) - length(x.idx)
        if (sargan["df"] > 0L) {
          if (is.null(weights)) {
            fit_yres_on_z <- lm.fit(x = imat, y = res)
            rssr <- sum((res - mean(res))^2)
            sse2 <- sum(fit_yres_on_z$residuals * fit_yres_on_z$residuals)
          } else {
            fit_yres_on_z <- lm.wfit(x = imat, y = res, weights = weights)
            rssr <- sum(weights * (res - weighted.mean(res, weights))^2)
            sse2 <- sum(weights * fit_yres_on_z$residuals *
              fit_yres_on_z$residuals)
          }
          sargan["stat"] <- length(res) * (1 - sse2 / rssr)
          sargan["pvalue"] <- pchisq(sargan["stat"], sargan["df"],
            lower.tail = FALSE
          )
        }
      }

      # add info to eqs list
      eqs[[b]][[j]]$coef <- unname(fit_y_on_xhat$coefficients)
      eqs[[b]][[j]]$nobs <- nrow(xmat)
      eqs[[b]][[j]]$df_res <- df_res
      eqs[[b]][[j]]$resvar <- resvar
      eqs[[b]][[j]]$resvar_df_res <- resvar_df_res
      eqs[[b]][[j]]$XX <- crossprod(cbind(1, xmat)) # needed? or only vcov?
      eqs[[b]][[j]]$vcov <- vcov
      eqs[[b]][[j]]$sargan <- sargan
    } # eqs
  } # nblocks

  # return theta1
  theta1 <- x[free.directed.idx]

  # add equations as an attribute
  attr(theta1, "eqs") <- eqs

  theta1
}

# stage 1: use 2SLS to find the regression coefficients of all
#          directed effects in the model -- samplestats version
lav_sem_miiv_2sls_samplestats <- function(eqs = NULL, lavmodel = NULL,
                                          lavpartable = NULL, lavdata = NULL,
                                          lavsamplestats = NULL, lavh1 = NULL,
                                          free.directed.idx = NULL) {
  # helper function: first chol, then eigen if chol fails
  solve_spd <- function(A, B, tol = 1e-10) {
    cholA <- try(chol(A), silent = TRUE)
    if (!inherits(cholA, "try-error")) {
      # Cholesky solve
      return(backsolve(cholA, forwardsolve(t(cholA), B)))
    } else {
      # Eigen fallback (pseudo-inverse)
      eig <- eigen(A, symmetric = TRUE)
      keep <- eig$values > tol * max(eig$values)
      Ainv <- eig$vectors[, keep, drop = FALSE] %*%
        diag(1 / eig$values[keep], length(eig$values[keep])) %*%
        t(eig$vectors[, keep, drop = FALSE])
      return(Ainv %*% B)
    }
  }

  # no conditional.x for now!
  stopifnot(!lavmodel@conditional.x)

  # get lavpta
  lavpta <- lav_partable_attributes(lavpartable)

  if (is.null(eqs)) {
    # find ALL model-implied instrumental variables (miivs) per equation
    eqs <- lav_model_find_iv(lavmodel = lavmodel, lavpta = lavpta)
  }

  # number of blocks
  nblocks <- lavmodel@nblocks

  # parameter vector -> all NA (for the free parameters)
  x <- lav_model_get_parameters(lavmodel) * as.numeric(NA)

  # 2SLS per equation
  # for now: - no equality constraints (yet)
  #          - only OLS (not robust, no lasso, ...)
  for (b in seq_len(nblocks)) {
    # ov.names for this block
    ov.names <- lavpta$vnames$ov[[b]]

    # sample statistics for this block
    sample.cov <- lavh1$implied$cov[[b]]
    sample.mean <- lavh1$implied$mean[[b]]

    # nobs for this 'block'
    nobs <- lavsamplestats@nobs[[b]]

    # estimation per equation
    for (j in seq_along(eqs[[b]])) {
      # this equation
      eq <- eqs[[b]][[j]]

      # iv_flag?
      iv_flag <- TRUE
      if (!is.null(eq$iv_flag)) {
        iv_flag <- eq$iv_flag
      } else {
        # if rhs_new matches miiv, iv_flag is FALSE
        if (identical(eq$rhs_new, eq$miiv)) {
          iv_flag <- FALSE
        }
      }

      # Y: there is always an y variable
      y.idx <- match(eq$lhs_new, ov.names)
      y.bar <- sample.mean[y.idx]

      # X: usually, there are x variables (apart from the "1")
      if (identical(eq$rhs_new, "1")) {
        x.idx <- integer(0L)
      } else {
        x.idx <- match(eq$rhs_new, ov.names)
        x.bar <- sample.mean[x.idx]
      }

      # Z: instruments
      S_Xy <- sample.cov[x.idx, y.idx, drop = FALSE]
      S_XX <- sample.cov[x.idx, x.idx, drop = FALSE]
      s_yy <- sample.cov[y.idx, y.idx, drop = FALSE]
      if (iv_flag) {
        i.idx <- match(eq$miiv, ov.names)
        S_XZ <- sample.cov[x.idx, i.idx, drop = FALSE]
        S_ZX <- sample.cov[i.idx, x.idx, drop = FALSE]
        S_ZZ <- sample.cov[i.idx, i.idx, drop = FALSE]
        S_Zy <- sample.cov[i.idx, y.idx, drop = FALSE]
      }

      # sargan vector
      sargan <- rep(as.numeric(NA), 3L)
      names(sargan) <- c("stat", "df", "pvalue")

      # 0. check
      if (iv_flag && length(eq$miiv) < length(eq$rhs)) {
        # what to do? skip, or proceed anyway?
        eqs[[b]][[j]]$coef <- numeric(0L)
        eqs[[b]][[j]]$nobs <- nobs
        eqs[[b]][[j]]$df_res <- as.integer(NA)
        eqs[[b]][[j]]$resvar <- as.numeric(NA)
        eqs[[b]][[j]]$resvar_df_res <- as.numeric(NA)
        eqs[[b]][[j]]$XX <- matrix(0, 0L, 0L)
        eqs[[b]][[j]]$vcov <- matrix(0, 0L, 0L)
        eqs[[b]][[j]]$sargan <- sargan
        next
      }

      fit_y_on_xhat <- list()
      if (iv_flag) {
        # Step 1: compute S_ZZ^{-1} S_ZX and S_ZZ^{-1} S_Zy
        W <- solve_spd(S_ZZ, S_ZX)
        v <- solve_spd(S_ZZ, S_Zy)
        # Step 2: build reduced system
        Amat <- S_XZ %*% W
        bvec <- S_XZ %*% v
        beta_slopes <- drop(solve_spd(Amat, bvec))
        beta0 <- as.vector(y.bar - t(x.bar) %*% beta_slopes)
      } else {
        if (length(x.idx) > 0L) {
          Amat <- S_XX
          bvec <- S_Xy
          beta_slopes <- drop(solve_spd(Amat, bvec))
          beta0 <- as.vector(y.bar - t(x.bar) %*% beta_slopes)
        } else {
          beta_slopes <- numeric(0L)
          beta0 <- y.bar
        }
      }
      fit_y_on_xhat$coefficients <- c(beta0, beta_slopes)

      # 3. fill estimates in x
      # - eq$pt contains partable/user rows
      # - lavpartable$free[eq$pt] should give the free idx
      free.idx <- lavpartable$free[eq$pt]
      if (length(x.idx) > 0L) {
        if (all(free.idx > 0L)) {
          x[free.idx] <- fit_y_on_xhat$coefficients[-1]
        } else {
          # remove non-free elements
          zero.idx <- which(free.idx == 0L)
          free.idx <- free.idx[-zero.idx]
          if (length(free.idx) > 0) {
            x[free.idx] <- fit_y_on_xhat$coefficients[-1][-zero.idx]
          }
        }
      }
      if (lavmodel@meanstructure) {
        free.int.idx <- lavpartable$free[eq$ptint]
        if (free.int.idx > 0L) {
          x[free.int.idx] <- fit_y_on_xhat$coefficients[1]
        }
      }

      # 4. resvar
      if (length(x.idx) > 0L) {
        tmp <- S_XX %*% beta_slopes
        resvar <- as.numeric(s_yy - 2 * t(beta_slopes) %*% S_Xy +
          t(beta_slopes) %*% tmp)
      } else {
        resvar <- drop(s_yy)
      }
      df_res <- nobs - (length(x.idx) + 1L)
      resvar_df_res <- resvar * nobs / df_res

      # 5. naive cov (for standard errors) (see summary.lm in base R)
      if (length(x.idx) > 0L) {
        Ainv <- solve_spd(Amat, diag(x = 1, nrow = nrow(Amat)))
        vcov.slopes <- (resvar / nobs) * Ainv
        vcov.beta0 <- (resvar / nobs) + t(x.bar) %*% vcov.slopes %*% x.bar
        cov.beta0.slopes <- -vcov.slopes %*% x.bar
        vcov <- matrix(0, length(x.idx) + 1L, length(x.idx) + 1L)
        vcov[1, 1] <- vcov.beta0
        vcov[1, -1] <- t(cov.beta0.slopes)
        vcov[-1, 1] <- cov.beta0.slopes
        vcov[-1, -1] <- vcov.slopes
      } else {
        # only intercept
        vcov <- matrix(resvar / nobs, 1L, 1L)
      }

      # 6. Sargan test (see summary.ivreg.R 363--371)
      if (iv_flag) {
        sargan["df"] <- length(i.idx) - length(x.idx)
        if (sargan["df"] > 0L) {
          g <- S_Zy - S_ZX %*% beta_slopes
          w <- solve_spd(S_ZZ, g)
          sargan["stat"] <- as.numeric(nobs * t(g) %*% w / resvar)
          sargan["pvalue"] <- pchisq(sargan["stat"], sargan["df"],
            lower.tail = FALSE
          )
        }
      }

      # XX (needed?)
      if (length(x.idx) > 0L) {
        XX <- tcrossprod(c(1, x.bar)) * nobs
        XX[-1, -1] <- (S_XX + tcrossprod(x.bar)) * nobs
      } else {
        XX <- matrix(nobs, 1L, 1L)
      }

      # add info to eqs list
      eqs[[b]][[j]]$coef <- unname(fit_y_on_xhat$coefficients)
      eqs[[b]][[j]]$nobs <- nobs
      eqs[[b]][[j]]$df_res <- df_res
      eqs[[b]][[j]]$resvar <- resvar
      eqs[[b]][[j]]$resvar_df_res <- resvar_df_res
      eqs[[b]][[j]]$XX <- XX
      eqs[[b]][[j]]$vcov <- vcov
      eqs[[b]][[j]]$sargan <- sargan
    } # eqs
  } # nblocks

  # return theta1
  theta1 <- x[free.directed.idx]

  # add equations as an attribute
  attr(theta1, "eqs") <- eqs

  theta1
}


# by default: input (x) is theta1 (only)
# BUT if impliedvec is TRUE, then x contains the sample statisics
# this allows us to compute the jacobian wrt theta1 elements (keeping
# sample statistics fixed, or the jacobian wrt the sample statistics
# (keeping theta1 fixed)
lav_sem_miiv_varcov <- function(x = NULL, impliedvec = FALSE,
                                lavmodel = NULL, lavpartable = NULL,
                                lavh1 = NULL, free.directed.idx = NULL,
                                free.undirected.idx = NULL,
                                iv.varcov.method = "RLS") {
  if (impliedvec) {
    implied <- lav_vec_to_implied(x, lavmodel = lavmodel)
    x <- lav_model_get_parameters(lavmodel)
    theta1 <- x[free.directed.idx]
  } else {
    theta1 <- x
    x <- lav_model_get_parameters(lavmodel)
    x[free.directed.idx] <- theta1
    implied <- lavh1$implied
  }

  # number of blocks
  nblocks <- lavmodel@nblocks

  # preparations
  lavmodel.tmp <- lav_model_set_parameters(lavmodel = lavmodel, x = x)
  delta_block <- lav_model_delta(
    lavmodel = lavmodel.tmp,
    ceq.simple = lavmodel@ceq.simple.only
  )

  # create block-diagonal W_2 and s
  w2_block <- vector("list", length = nblocks)
  s_block <- vector("list", length = nblocks)
  delta2_block <- vector("list", length = nblocks)
  for (b in seq_len(nblocks)) {
    sample_cov <- implied$cov[[b]]
    sample_mean <- implied$mean[[b]]

    # delta2
    delta2_block[[b]] <- delta_block[[b]][, free.undirected.idx, drop = FALSE]
    if (iv.varcov.method == "GLS") {
      s.inv <- solve(sample_cov)
    } else { # ULS, or starting point for 2RLS/RLS
      s.inv <- diag(1, nrow = nrow(sample_cov))
    }
    w2_22 <- 0.5 * lav_matrix_duplication_pre_post(s.inv %x% s.inv)
    if (lavmodel@meanstructure) {
      w2_11 <- s.inv
      w2_block[[b]] <- lav_matrix_bdiag(w2_11, w2_22)
      s_block[[b]] <- c(sample_mean, lav_matrix_vech(sample_cov))
    } else {
      w2_block[[b]] <- w2_22
      s_block[[b]] <- lav_matrix_vech(sample_cov)
    }
  }
  Delta2 <- do.call("rbind", delta2_block)
  W2 <- lav_matrix_bdiag(w2_block)
  svech <- unlist(s_block)

  # initial estimate for theta.2
  # TODO: if any constraints are needed, we need to augment the information
  theta2 <- drop(solve(
    t(Delta2) %*% W2 %*% Delta2,
    t(Delta2) %*% W2 %*% svech
  ))

  # again, but now with Sigma
  if (iv.varcov.method == "2RLS") {
    x[free.undirected.idx] <- theta2
    lavmodel.tmp <- lav_model_set_parameters(lavmodel = lavmodel, x = x)
    sigma <- lav_model_sigma(lavmodel = lavmodel.tmp, extra = FALSE)
    w2_block <- vector("list", length = nblocks)
    for (b in seq_len(nblocks)) {
      # delta2
      s.inv <- solve(sigma[[b]])
      w2_22 <- 0.5 * lav_matrix_duplication_pre_post(s.inv %x% s.inv)
      if (lavmodel@meanstructure) {
        w2_11 <- s.inv
        w2_block[[b]] <- lav_matrix_bdiag(w2_11, w2_22)
      } else {
        w2_block[[b]] <- w2_22
      }
    }
    W2 <- lav_matrix_bdiag(w2_block)
    # final estimate for theta.2
    # TODO: if any constraints are needed, we need to augment the information
    theta2 <- drop(solve(
      t(Delta2) %*% W2 %*% Delta2,
      t(Delta2) %*% W2 %*% svech
    ))
  } else if (iv.varcov.method == "RLS") {
    for (i in 1:200) {
      old_x <- theta2
      x[free.undirected.idx] <- theta2
      lavmodel.tmp <- lav_model_set_parameters(lavmodel = lavmodel, x = x)
      sigma <- lav_model_sigma(lavmodel = lavmodel.tmp, extra = FALSE)
      w2_block <- vector("list", length = nblocks)
      for (b in seq_len(nblocks)) {
        # delta2
        s.inv <- solve(sigma[[b]])
        w2_22 <- 0.5 * lav_matrix_duplication_pre_post(s.inv %x% s.inv)
        if (lavmodel@meanstructure) {
          w2_11 <- s.inv
          w2_block[[b]] <- lav_matrix_bdiag(w2_11, w2_22)
        } else {
          w2_block[[b]] <- w2_22
        }
      }
      W2 <- lav_matrix_bdiag(w2_block)
      # final estimate for theta.2
      # TODO: if any constraints are needed, we need to augment the information
      theta2 <- drop(solve(
        t(Delta2) %*% W2 %*% Delta2,
        t(Delta2) %*% W2 %*% svech
      ))
      sse <- sum((old_x - theta2)^2)
      # cat("i = ", i, "sse = ", sse, "\n")
      if (sse < 1e-05) {
        break
      } else if (i == 200L) {
        lav_msg_warn(gettext("RLS for variances/covariances did not converge
                              after 200 iterations."))
      }
    }
  }

  theta2
}


# VCOV for free parameters
lav_sem_miiv_vcov <- function(lavmodel = NULL, lavsamplestats = NULL,
                              lavoptions = NULL, lavpartable = NULL,
                              lavimplied = NULL,
                              lavh1 = NULL, eqs = NULL) {
  # iv options
  iv.varcov.se <- lavoptions$estimator.args$iv.varcov.se
  iv.varcov.modelbased <- lavoptions$estimator.args$iv.varcov.modelbased
  iv.varcov.method <- toupper(lavoptions$estimator.args$iv.varcov.method)

  # empty vcov
  vcov <- matrix(0, lavmodel@nx.free, lavmodel@nx.free)

  # nblocks
  nblocks <- lavmodel@nblocks

  # FIXME: what about scaling parameters (~*~)? (ignored for now)

  undirected.idx <- which(lavpartable$free > 0L &
    !duplicated(lavpartable$free) & # if ceq.simple
    lavpartable$op == "~~")
  directed.idx <- which(lavpartable$free > 0L &
    !duplicated(lavpartable$free) & # if ceq.simple
    !lavpartable$op %in% c("~~", "~*~"))
  free.directed.idx <- unique(lavpartable$free[directed.idx])
  free.undirected.idx <- unique(lavpartable$free[undirected.idx])

  # directed free parameters only
  x <- lav_model_get_parameters(lavmodel, type = "free")
  theta1 <- x[free.directed.idx]


  # stage 1: directed effects
  for (b in seq_len(nblocks)) {
    neqs <- length(eqs[[b]])
    for (j in seq_len(neqs)) {
      eq <- eqs[[b]][[j]]

      if (!is.null(eq$vcov) && nrow(eq$vcov) > 0L) {
        eq_vcov <- eq$vcov # always includes intercept
      } else if (!is.null(eq$XX) && !is.null(eq$resvar)) {
        # reconstruct using XX and resvar (less stable!)
        eq_vcov <- solve(crossprod(eq$XX)) * eq$resvar # or resvar_df_res
      }

      # only keep free parameters
      free.idx <- lavpartable$free[eq$pt]
      if (length(eq$rhs) > 0L) {
        if (all(free.idx > 0L)) {
          vcov[free.idx, free.idx] <- eq_vcov[-1, -1]
        } else {
          # remove non-free elements
          zero.idx <- which(free.idx == 0L)
          free.idx <- free.idx[-zero.idx]
          if (length(free.idx) > 0L) {
            vcov[free.idx, free.idx] <-
              eq_vcov[-1, -1][-zero.idx, -zero.idx, drop = FALSE]
          }
        }
      }
      if (lavmodel@meanstructure) {
        free.int.idx <- lavpartable$free[eq$ptint]
        if (free.int.idx > 0L) {
          vcov[free.int.idx, free.int.idx] <- eq_vcov[1, 1]
        }
      }
    } # neqs
  } # nblocks

  # stage 2: undirected effects (note: intercepts have no effect!)

  if (iv.varcov.se) {
    # part a: effect of theta1
    jac_a <- try(lav_func_jacobian_complex(
      func = lav_sem_miiv_varcov,
      x = theta1, impliedvec = FALSE, lavmodel = lavmodel,
      lavpartable = lavpartable, lavh1 = lavh1,
      free.directed.idx = free.directed.idx,
      free.undirected.idx = free.undirected.idx,
      iv.varcov.method = iv.varcov.method
    ), silent = TRUE)
    if (inherits(jac_a, "try-error")) {
      jac_a <- numDeriv::jacobian(
        func = lav_sem_miiv_varcov,
        x = theta1, impliedvec = FALSE, lavmodel = lavmodel,
        lavpartable = lavpartable, lavh1 = lavh1,
        free.directed.idx = free.directed.idx,
        free.undirected.idx = free.undirected.idx,
        iv.varcov.method = iv.varcov.method
      )
    }
    vcov_directed <- vcov[free.directed.idx, free.directed.idx, drop = FALSE]
    vcov_a <- jac_a %*% vcov_directed %*% t(jac_a)

    # part b: effect of sample statistics
    # - get jacobian lav_sem_miiv_varcov wrt implied_vec
    # - get Gamma (NT or ADF)
    # - vcov_undirected_b <- jac_b %*% gamma_mat %*% t(jac_b)
    vec <- lav_implied_to_vec(
      implied = lavh1$implied, lavmodel = lavmodel,
      drop.list = TRUE
    )
    jac_b <- try(lav_func_jacobian_complex(
      func = lav_sem_miiv_varcov,
      x = vec, impliedvec = TRUE, lavmodel = lavmodel,
      lavpartable = lavpartable, lavh1 = lavh1,
      free.directed.idx = free.directed.idx,
      free.undirected.idx = free.undirected.idx,
      iv.varcov.method = iv.varcov.method
    ), silent = TRUE)
    if (inherits(jac_b, "try-error")) {
      jac_b <- numDeriv::jacobian(
        func = lav_sem_miiv_varcov,
        x = vec, impliedvec = TRUE, lavmodel = lavmodel,
        lavpartable = lavpartable, lavh1 = lavh1,
        free.directed.idx = free.directed.idx,
        free.undirected.idx = free.undirected.idx,
        iv.varcov.method = iv.varcov.method
      )
    }

    # Gamma matrix per group
    gamma_g <- vector("list", lavmodel@ngroups)
    for (g in seq_len(lavmodel@ngroups)) {
      if (!is.null(lavsamplestats@NACOV[[g]])) {
        gamma_g <- lavsamplestats@NACOV[[g]]
      } else {
        if (iv.varcov.modelbased) {
          mean_g <- lavimplied$mean[[g]]
          cov_g <- lavimplied$cov[[g]]
        } else {
          mean_g <- lavh1$implied$mean[[g]]
          cov_g <- lavh1$implied$cov[[g]]
        }
        # NT version (for now), model-based
        gamma_g <- lav_samplestats_Gamma_NT(
          COV = cov_g,
          MEAN = mean_g,
          x.idx = lavsamplestats@x.idx[[g]],
          fixed.x = lavmodel@fixed.x,
          conditional.x = lavmodel@conditional.x,
          meanstructure = lavmodel@meanstructure,
          slopestructure = lavmodel@conditional.x
        )
        # divide by (group) sample size
        gamma_g <- gamma_g / lavsamplestats@nobs[[g]]
      }
    }
    gamma_big <- lav_matrix_bdiag(gamma_g)
    vcov_b <- jac_b %*% gamma_big %*% t(jac_b)

    vcov_ab <- vcov_a + vcov_b
    vcov[free.undirected.idx, free.undirected.idx] <- vcov_ab
  } # iv.varcov.se = TRUE

  vcov
}

lav_lavaan_step11_estoptim <- function(lavdata = NULL, # nolint
                                       lavmodel = NULL,
                                       lavcache = NULL,
                                       lavsamplestats = NULL,
                                       lavh1 = NULL,
                                       lavoptions = NULL,
                                       lavpartable = NULL) {
  # # # # # # # # # # # # # #
  # #  11. est + lavoptim # #
  # # # # # # # # # # # # # #

  # if lavoptions$do.fit and lavoptions$estimator not "none" and
  #   lavmodel$nx.free > 0
  #   select case lavoptions$optim.method
  #   case "noniter"
  #     try x <- lav_optim_noniter(...)
  #   case "em"
  #     if nlevels < 2L *** error ***
  #     try x <- lav_mvnorm_cluster_em_h0(...)
  #   case "gn"
  #     try x <- lav_optim_gn(...)
  #   case else
  #     set 1 in lavoptions$optim.attempts is it wasn't specified
  #     try x <- lav_model_estimate(...)
  #     if not successfull and optim.attempts > 1L
  #       try x <- lav_optim_estimate(...) with
  #         options$optim.parscale = "standardized"
  #       if not successfull and optim.attempts > 2L
  #         try x <- lav_optim_estimate(...) with start = "simple"
  #         if not successfull and optim.attempts > 3L
  #           try x <- lav_optim_estimate(...) with
  #             options$optim.parscale = "standardized" and start = "simple"
  #   end select
  #   if x not succesfully computed
  #     ** warning **
  #     set starting values and appropriate attributes in x
  #   in case of non-linear constraints: store final con.jac and
  #     con.lambda in lavmodel
  #   store parameters in lavmodel
  #   store parameters in partable$est
  # else
  #   initialize x and attributes (iterations, converged, warn.txt,
  #     control, dx) of x
  #   try fx <- lav_model_objective
  #   if not successfull
  #     fx = NA_real_
  #     attribute fx.group of fx = NA_real_
  #   store fx in attribute "fx" of x
  #   set lavpartable$est to starting values
  # if lavoptions$optim.force.converged set attribute converged of x to TRUE
  # store optimization info in lavoptim

  x <- NULL
  if (lavoptions$do.fit && lavoptions$estimator != "none" &&
    lavmodel@nx.free > 0L) {
    if (lav_verbose()) {
      cat("lavoptim           ... start:\n")
    }

    # non-iterative methods (fabin, miiv, ...)
    if (lavoptions$optim.method == "noniter") {
      x <- try(
        lav_optim_noniter(
          lavmodel = lavmodel,
          lavsamplestats = lavsamplestats,
          lavh1 = lavh1,
          lavdata = lavdata,
          lavpartable = lavpartable,
          lavoptions = lavoptions
        ),
        silent = FALSE
      )
      # EM for multilevel models
    } else if (lavoptions$optim.method == "em") {
      # multilevel only for now
      stopifnot(lavdata@nlevels > 1L)
      x <- try(
        lav_mvnorm_cluster_em_h0(
          lavsamplestats = lavsamplestats,
          lavdata = lavdata,
          lavimplied = NULL,
          lavpartable = lavpartable,
          lavmodel = lavmodel,
          lavoptions = lavoptions,
          fx.tol = lavoptions$em.fx.tol,
          dx.tol = lavoptions$em.dx.tol,
          max.iter = lavoptions$em.iter.max
        ),
        silent = TRUE
      )
      # Gauss-Newton
    } else if (lavoptions$optim.method == "gn") {
      # only tested for DLS (for now)
      x <- try(
        lav_optim_gn(
          lavmodel = lavmodel,
          lavsamplestats = lavsamplestats,
          lavdata = lavdata,
          lavpartable = lavpartable,
          lavoptions = lavoptions
        ),
        silent = TRUE
      )

      # Quasi-Newton
    } else {
      # for backwards compatibility (<0.6)
      if (is.null(lavoptions$optim.attempts)) {
        lavoptions$optim.attempts <- 1L
      }

      # try 1
      if (lav_verbose()) {
        cat("attempt 1 -- default options\n")
      }
      x <- try(
        lav_model_estimate(
          lavmodel = lavmodel,
          lavpartable = lavpartable,
          lavsamplestats = lavsamplestats,
          lavdata = lavdata,
          lavoptions = lavoptions,
          lavcache = lavcache
        ),
        silent = TRUE
      )

      # try 2: optim.parscale = "standardize" (new in 0.6-7)
      if (lavoptions$optim.attempts > 1L &&
        lavoptions$rstarts == 0L &&
        (inherits(x, "try-error") || !attr(x, "converged"))) {
        lavoptions2 <- lavoptions
        lavoptions2$optim.parscale <- "standardized"
        if (lav_verbose()) {
          str(x)
          cat("attempt 2 -- optim.parscale = \"standardized\"\n")
        }
        x <- try(
          lav_model_estimate(
            lavmodel = lavmodel,
            lavpartable = lavpartable,
            lavsamplestats = lavsamplestats,
            lavdata = lavdata,
            lavoptions = lavoptions2,
            lavcache = lavcache
          ),
          silent = TRUE
        )
      }

      # try 3: start = "simple"
      if (lavoptions$optim.attempts > 2L &&
        lavoptions$rstarts == 0L &&
        (inherits(x, "try-error") || !attr(x, "converged"))) {
        if (lav_verbose()) {
          str(x)
          cat("attempt 3 -- start = \"simple\"\n")
        }
        x <- try(
          lav_model_estimate(
            lavmodel = lavmodel,
            lavpartable = lavpartable,
            lavsamplestats = lavsamplestats,
            lavdata = lavdata,
            lavoptions = lavoptions,
            start = "simple",
            lavcache = lavcache
          ),
          silent = TRUE
        )
      }

      # try 4: start = "simple" + optim.parscale = "standardize"
      if (lavoptions$optim.attempts > 3L &&
        lavoptions$rstarts == 0L &&
        (inherits(x, "try-error") || !attr(x, "converged"))) {
        lavoptions2 <- lavoptions
        lavoptions2$optim.parscale <- "standardized"
        if (lav_verbose()) {
          str(x)
          cat(
            "attempt 4 -- optim.parscale = \"standardized\" + ",
            "start = \"simple\"\n"
          )
        }
        x <- try(
          lav_model_estimate(
            lavmodel = lavmodel,
            lavpartable = lavpartable,
            lavsamplestats = lavsamplestats,
            lavdata = lavdata,
            lavoptions = lavoptions2,
            start = "simple",
            lavcache = lavcache
          ),
          silent = TRUE
        )
      }


      # random starts? -- new in 0.6-18
      # run this even if we already have a converged solution
      # perhaps we find a better solution?
      if (lavoptions$rstarts > 0L) {
        x.rstarts <- vector("list", length = lavoptions$rstarts)
        if (lav_verbose()) {
          str(x)
          cat("trying again with random starts (", lavoptions$rstarts,
            " in total):\n",
            sep = ""
          )
        }
        for (i in seq_len(lavoptions$rstarts)) {
          if (lav_verbose()) {
            cat("-- random start run: ", i, "\n")
          }
          x.rstarts[[i]] <-
            try(
              lav_model_estimate(
                lavmodel = lavmodel,
                lavpartable = lavpartable,
                lavsamplestats = lavsamplestats,
                lavdata = lavdata,
                lavoptions = lavoptions,
                start = "random",
                lavcache = lavcache
              ),
              silent = TRUE
            )
        }

        # pick best solution (if any)
        x.converged <- vector("list", length = 0L)
        fx.rstarts <- numeric(0L)
        ok.flag <- sapply(x.rstarts, function(x) {
            if (inherits(x, "try-error")) {
              return(FALSE)
            } else {
              return(attr(x, "converged"))
            }
          })
        if (sum(ok.flag) > 0L) {
          x.converged <- x.rstarts[ok.flag]
        }
        if (length(x.converged) > 0L) {
          fx.rstarts <- sapply(x.converged, "attr", "fx")
          x.best <- x.converged[[which.min(fx.rstarts)]]
          fx.best <- attr(x.best, "fx")[1]

          # if we did not find a converged solution, use x.best
          if (inherits(x, "try-error") || !attr(x, "converged")) {
            x <- x.best


            # if we already had a converged solution, only replace
            # if fx.best is better than attr(x, "fx")[1]
          } else {
            if (fx.best < attr(x, "fx")[1]) {
              x <- x.best
            }
          }
        }

        attr(x, "x.rstarts") <- x.rstarts
      } # random starts
    }

    # optimization failed with error
    if (inherits(x, "try-error")) {
      warn.txt <- gettext("Model estimation FAILED! Returning starting values.")
      x <- lav_model_get_parameters(
        lavmodel = lavmodel,
        type = "free"
      ) # starting values
      attr(x, "iterations") <- 0L
      attr(x, "converged") <- FALSE
      attr(x, "warn.txt") <- warn.txt
      attr(x, "control") <- lavoptions$control
      attr(x, "dx") <- numeric(0L)
      fx <- as.numeric(NA)
      attr(fx, "fx.group") <- as.numeric(NA)
      attr(x, "fx") <- fx
    }

    # if a warning was produced, say it here
    warn.txt <- attr(x, "warn.txt")
    if (!is.null(warn.txt) && nchar(warn.txt) > 0L) {
      lav_msg_warn(gettext(warn.txt))
    }

    # in case of non-linear constraints: store final con.jac and con.lambda
    # in lavmodel
    if (!is.null(attr(x, "con.jac"))) {
      lavmodel@con.jac <- attr(x, "con.jac")
    }
    if (!is.null(attr(x, "con.lambda"))) {
      lavmodel@con.lambda <- attr(x, "con.lambda")
    }

    # store parameters in lavmodel
    lavmodel <- lav_model_set_parameters(lavmodel, x = as.numeric(x))

    # store parameters in @ParTable$est
    lavpartable$est <- lav_model_get_parameters(
      lavmodel = lavmodel,
      type = "user", extra = TRUE
    )

    if (lav_verbose()) {
      cat("lavoptim    ... done.\n")
    }
  } else {
    x <- numeric(0L)
    attr(x, "iterations") <- 0L
    attr(x, "converged") <- FALSE
    attr(x, "warn.txt") <- ""
    attr(x, "control") <- lavoptions$control
    attr(x, "dx") <- numeric(0L)
    fx <- try(lav_model_objective(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavcache = lavcache
    ), silent = TRUE)
    if (!inherits(fx, "try-error")) {
      attr(x, "fx") <- fx
    } else {
      fx <- as.numeric(NA)
      attr(fx, "fx.group") <- as.numeric(NA)
      attr(x, "fx") <- fx
    }

    lavpartable$est <- lavpartable$start
  }

  # should we fake/force convergence? (eg. to enforce the
  # computation of a test statistic)
  if (lavoptions$optim.force.converged) {
    attr(x, "converged") <- TRUE
  }

  # store optimization info in lavoptim
  lavoptim <- list()
  x2 <- x
  attributes(x2) <- NULL
  lavoptim$x <- x2
  lavoptim$dx <- attr(x, "dx")
  lavoptim$npar <- length(x)
  lavoptim$iterations <- attr(x, "iterations")
  lavoptim$converged <- attr(x, "converged")
  lavoptim$warn.txt <- attr(x, "warn.txt")
  lavoptim$parscale <- attr(x, "parscale")
  lavoptim$partrace <- attr(x, "partrace")
  fx.copy <- fx <- attr(x, "fx")
  attributes(fx) <- NULL
  lavoptim$fx <- fx
  lavoptim$fx.group <- attr(fx.copy, "fx.group")
  if (!is.null(attr(fx.copy, "logl.group"))) {
    lavoptim$logl.group <- attr(fx.copy, "logl.group")
    lavoptim$logl <- sum(lavoptim$logl.group)
  } else {
    lavoptim$logl.group <- as.numeric(NA)
    lavoptim$logl <- as.numeric(NA)
  }
  lavoptim$control <- attr(x, "control")
  if (!is.null(attr(x, "x.rstarts"))) {
    lavoptim$x.rstarts <- attr(x, "x.rstarts")
  }

  lavpartable <- lav_partable_set_cache(lavpartable, force = TRUE)
  list(
    lavoptim = lavoptim, lavmodel = lavmodel, lavpartable = lavpartable,
    x = x
  )
}

# get missing patterns
lav_data_missing_patterns <- function(Y, sort.freq = FALSE, coverage = FALSE,
                                      Lp = NULL) {
  # handle two-level data
  if (!is.null(Lp)) {
    Y.orig <- Y
    Z <- NULL
    if (length(Lp$between.idx[[2]]) > 0L) {
      Y <- Y[, -Lp$between.idx[[2]], drop = FALSE]
      z.idx <- which(!duplicated(Lp$cluster.idx[[2]]))
      Z <- Y.orig[z.idx, Lp$between.idx[[2]], drop = FALSE]
    }
  }

  # construct TRUE/FALSE matrix: TRUE if value is observed
  OBS <- !is.na(Y)

  # empty cases
  empty.idx <- which(rowSums(OBS) == 0L)

  # pattern of observed values per observation
  case.id <- apply(1L * OBS, 1L, paste, collapse = "")

  # remove empty patterns
  if (length(empty.idx)) {
    case.id.nonempty <- case.id[-empty.idx]
  } else {
    case.id.nonempty <- case.id
  }

  # sort non-empty patterns (from high occurence to low occurence)
  if (sort.freq) {
    TABLE <- sort(table(case.id.nonempty), decreasing = TRUE)
  } else {
    TABLE <- table(case.id.nonempty)
  }

  # unique pattern ids
  pat.id <- names(TABLE)

  # number of patterns
  pat.npatterns <- length(pat.id)

  # case idx per pattern
  pat.case.idx <- lapply(
    seq_len(pat.npatterns),
    function(p) which(case.id == pat.id[p])
  )

  # unique pattern frequencies
  pat.freq <- as.integer(TABLE)

  # first occurrence of each pattern
  pat.first <- match(pat.id, case.id)

  # TRUE/FALSE for each pattern
  pat.obs <- OBS[pat.first, , drop = FALSE] # observed per pattern

  Mp <- list(
    npatterns = pat.npatterns, id = pat.id, freq = pat.freq,
    case.idx = pat.case.idx, pat = pat.obs, empty.idx = empty.idx,
    nel = sum(OBS)
  )

  if (coverage) {
    # FIXME: if we have empty cases, include them in N?
    # no for now
    Mp$coverage <- crossprod(OBS) / sum(pat.freq)
    # Mp$coverage <- crossprod(OBS) / NROW(Y)
  }

  # additional info in we have two-level data
  if (!is.null(Lp)) {
    Mp$j.idx <- lapply(
      seq_len(pat.npatterns),
      function(p) Lp$cluster.idx[[2]][Mp$case.idx[[p]]]
    )
    Mp$j1.idx <- lapply(
      seq_len(pat.npatterns),
      function(p) sort(unique.default(Mp$j.idx[[p]])) # new in 0.6-19: sort!!
	                                                  # because table/tabulate
													  # also sorts...
    )
    Mp$j.freq <- lapply(
      seq_len(pat.npatterns),
      function(p) as.integer(unname(table(sort(Mp$j.idx[[p]])))) # sort not needed?
    )

    # between-level patterns
    if (!is.null(Z)) {
      Mp$Zp <- lav_data_missing_patterns(Z,
        sort.freq = FALSE,
        coverage = FALSE, Lp = NULL
      )
    }
  }

  Mp
}

# get response patterns (ignore empty cases!)
lav_data_resp_patterns <- function(Y) {
  # construct TRUE/FALSE matrix: TRUE if value is observed
  OBS <- !is.na(Y)

  # empty cases
  empty.idx <- which(rowSums(OBS) == 0L)

  # removeYempty cases
  if (length(empty.idx) > 0L) {
    Y <- Y[-empty.idx, , drop = FALSE]
  }

  ntotal <- nrow(Y)
  nvar <- ncol(Y)

  # identify, label and sort response patterns
  id <- apply(Y, MARGIN = 1, paste, collapse = "")

  # sort patterns (from high occurence to low occurence)
  TABLE <- sort(table(id), decreasing = TRUE)
  order <- names(TABLE)
  npatterns <- length(TABLE)
  pat <- Y[match(order, id), , drop = FALSE]
  row.names(pat) <- as.character(TABLE)

  # handle NA?
  Y[is.na(Y)] <- -9
  total.patterns <- prod(apply(Y, 2, function(x) length(unique(x))))
  empty.patterns <- total.patterns - npatterns
  # return a list
  # out <- list(nobs=ntotal, nvar=nvar,
  #            id=id, npatterns=npatterns,
  #            order=order, pat=pat)

  # only return pat
  out <- list(
    npatterns = npatterns, pat = pat, total.patterns = total.patterns,
    empty.patterns = empty.patterns
  )

  out
}

# get cluster information
# - cluster can be a vector!
# - clus can contain multiple columns!
lav_data_cluster_patterns <- function(Y = NULL,
                                      clus = NULL, # the cluster ids
                                      cluster = NULL, # the cluster 'names'
                                      multilevel = FALSE,
                                      ov.names = NULL,
                                      ov.names.x = NULL,
                                      ov.names.l = NULL) {
  # how many levels?
  nlevels <- length(cluster) + 1L

  # did we get any data (or is this just for lav_data_simulate_old)
  if (!is.null(Y) && !is.null(clus)) {
    haveData <- TRUE
  } else {
    haveData <- FALSE
  }

  # check clus
  if (haveData) {
    stopifnot(ncol(clus) == (nlevels - 1L), nrow(Y) == nrow(clus))
  }

  cluster.size    <- vector("list", length = nlevels)
  cluster.id      <- vector("list", length = nlevels)
  cluster.idx     <- vector("list", length = nlevels)
  nclusters       <- vector("list", length = nlevels)
  cluster.sizes   <- vector("list", length = nlevels)
  ncluster.sizes  <- vector("list", length = nlevels)
  cluster.size.ns <- vector("list", length = nlevels)

  ov.idx          <- vector("list", length = nlevels)
  ov.x.idx        <- vector("list", length = nlevels)
  ov.y.idx        <- vector("list", length = nlevels)
  both.idx        <- vector("list", length = nlevels)
  within.idx      <- vector("list", length = nlevels)
  within.x.idx    <- vector("list", length = nlevels)
  within.y.idx    <- vector("list", length = nlevels)
  between.idx     <- vector("list", length = nlevels)
  between.x.idx   <- vector("list", length = nlevels)
  between.y.idx   <- vector("list", length = nlevels)
  both.names      <- vector("list", length = nlevels)
  within.names    <- vector("list", length = nlevels)
  within.x.names  <- vector("list", length = nlevels)
  within.y.names  <- vector("list", length = nlevels)
  between.names   <- vector("list", length = nlevels)
  between.x.names <- vector("list", length = nlevels)
  between.y.names <- vector("list", length = nlevels)

  # level-1 is special
  if (haveData) {
    nclusters[[1]] <- NROW(Y)
  }

  # higher levels:
  for (l in 2:nlevels) {
    if (haveData) {
      CLUS <- clus[, (l - 1L)]

	  # cluster.id: original cluster identifier
      cluster.id[[l]] <- unique(CLUS)

	  # cluster.idx: internal cluster idx (always an integer from 1 to J
	  # for every obervation;
	  # the first cluster id we observe is '1', the second '2', etc...)
      cluster.idx[[l]] <- match(CLUS, cluster.id[[l]])

      cluster.size[[l]] <- tabulate(cluster.idx[[l]])
      nclusters[[l]] <- length(cluster.size[[l]])
      # check if we have more observations than clusters
      if (nclusters[[1]] == nclusters[[l]]) {
        lav_msg_stop(gettext("every cluster contains only one observation."))
      }
      mean.cluster.size <- mean(cluster.size[[l]])
      if (mean.cluster.size < 1.5) {
        lav_msg_warn(gettextf(
          "mean cluster size is %s. This means that many clusters only
          contain a single observation.", mean.cluster.size))
        }
      cluster.sizes[[l]] <- unique(cluster.size[[l]])
      ncluster.sizes[[l]] <- length(cluster.sizes[[l]])
      cluster.size.ns[[l]] <- as.integer(table(factor(cluster.size[[l]],
        levels = as.character(cluster.sizes[[l]])
      )))
    } else {
      cluster.id[[l]] <- integer(0L)
      cluster.idx[[l]] <- integer(0L)
      cluster.size[[l]] <- integer(0L)
      nclusters[[l]] <- integer(0L)
      cluster.sizes[[l]] <- integer(0L)
      ncluster.sizes[[l]] <- integer(0L)
      cluster.size.ns[[l]] <- integer(0L)
    }
  }

  # for all levels:
  if (multilevel) {
    for (l in 1:nlevels) {
      # index of ov.names for this level
      ov.idx[[l]] <- match(ov.names.l[[l]], ov.names)

      # new in 0.6-12: always preserve the order of ov.idx[[l]]
      idx <- which(ov.names %in% ov.names.l[[1]] &
        ov.names %in% ov.names.l[[2]])
      both.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]

      idx <- which(ov.names %in% ov.names.l[[1]] &
        !ov.names %in% ov.names.l[[2]])
      within.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]
      # backwards compatibility: also store in within.idx[[2]]
      if (l == 2) {
        within.idx[[l]] <- within.idx[[1]]
      }

      idx <- which(!ov.names %in% ov.names.l[[1]] &
        ov.names %in% ov.names.l[[2]])
      between.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]

      # names
      # both.names[[l]]     <- ov.names[ ov.names %in% ov.names.l[[1]] &
      #                                 ov.names %in% ov.names.l[[2]] ]
      # within.names[[l]]   <- ov.names[ ov.names %in% ov.names.l[[1]] &
      #                                !ov.names %in% ov.names.l[[2]] ]
      # between.names[[l]]  <- ov.names[!ov.names %in% ov.names.l[[1]] &
      #                                 ov.names %in% ov.names.l[[2]] ]
      both.names[[l]] <- ov.names[both.idx[[l]]]
      within.names[[l]] <- ov.names[within.idx[[l]]]
      between.names[[l]] <- ov.names[between.idx[[l]]]
    }
  }

  # fixed.x wrt variable index
  if (multilevel && length(ov.names.x) > 0L) {
    for (l in 1:nlevels) {
      # some ov.names.x could be 'splitted', and end up in both.names
      # they should NOT be part ov.x.idx (as they become latent variables)
      idx <- which(ov.names %in% ov.names.x &
        ov.names %in% ov.names.l[[l]] &
        !ov.names %in% unlist(both.names))
      ov.x.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]

      # not any longer, we split them, but still treat them as 'fixed'
      # ov.x.idx[[l]] <- which( ov.names %in% ov.names.x &
      #                        ov.names %in% ov.names.l[[l]] )

      # if some ov.names.x have been 'splitted', and end up in both.names,
      # they should become part of ov.y.idx (despite being exogenous)
      # as they are now latent variables
      idx <- which(ov.names %in% ov.names.l[[l]] &
        !ov.names %in% ov.names.x[!ov.names.x %in% unlist(both.names)])
      ov.y.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]

      # not any longer, ov.x stays ov.x (even if we split)
      # ov.y.idx[[l]] <- which( ov.names %in% ov.names.l[[l]] &
      #                       !ov.names %in% ov.names.x )


      # if(l == 1L) {
      #    next
      # }
      # below, we only fill in the [[2]] element (and higher)

      idx <- which(ov.names %in% ov.names.l[[1]] &
        !ov.names %in% ov.names.l[[2]] &
        ov.names %in% ov.names.x)
      within.x.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]
      # backwards compatibility: also store in within.x.idx[[2]]
      if (l == 2) {
        within.x.idx[[l]] <- within.x.idx[[1]]
      }

      idx <- which(ov.names %in% ov.names.l[[1]] &
        !ov.names %in% ov.names.l[[2]] &
        !ov.names %in% ov.names.x)
      within.y.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]
      # backwards compatibility: also store in within.y.idx[[2]]
      if (l == 2) {
        within.y.idx[[l]] <- within.y.idx[[1]]
      }

      idx <- which(!ov.names %in% ov.names.l[[1]] &
        ov.names %in% ov.names.l[[2]] &
        ov.names %in% ov.names.x)
      between.x.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]

      idx <- which(!ov.names %in% ov.names.l[[1]] &
        ov.names %in% ov.names.l[[2]] &
        !ov.names %in% ov.names.x)
      between.y.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]

      # within.x.names[[l]]   <- ov.names[ ov.names %in% ov.names.l[[1]] &
      #                                   ov.names %in% ov.names.x &
      #                                  !ov.names %in% ov.names.l[[2]] ]
      # within.y.names[[l]]   <- ov.names[ ov.names %in% ov.names.l[[1]] &
      #                                  !ov.names %in% ov.names.x &
      #                                  !ov.names %in% ov.names.l[[2]] ]
      # between.x.names[[l]]  <- ov.names[!ov.names %in% ov.names.l[[1]] &
      #                                   ov.names %in% ov.names.x &
      #                                   ov.names %in% ov.names.l[[2]] ]
      # between.y.names[[l]]  <- ov.names[!ov.names %in% ov.names.l[[1]] &
      #                                  !ov.names %in% ov.names.x &
      #                                   ov.names %in% ov.names.l[[2]] ]
      within.x.names[[l]] <- ov.names[within.x.idx[[l]]]
      within.y.names[[l]] <- ov.names[within.y.idx[[l]]]
      between.x.names[[l]] <- ov.names[between.x.idx[[l]]]
      between.y.names[[l]] <- ov.names[between.y.idx[[l]]]
    }
  } else {
    ov.y.idx <- ov.idx
  }

  out <- list(
    ov.names = ov.names, ov.names.x = ov.names.x, # for this group
    cluster = cluster, # clus = clus,
    # per level
    nclusters = nclusters,
    cluster.size = cluster.size, cluster.id = cluster.id,
    cluster.idx = cluster.idx, cluster.sizes = cluster.sizes,
    ncluster.sizes = ncluster.sizes,
    cluster.size.ns = cluster.size.ns,
    ov.idx = ov.idx, ov.x.idx = ov.x.idx, ov.y.idx = ov.y.idx,
    both.idx = both.idx, within.idx = within.idx,
    within.x.idx = within.x.idx, within.y.idx = within.y.idx,
    between.idx = between.idx,
    between.x.idx = between.x.idx, between.y.idx = between.y.idx,
    both.names = both.names, within.names = within.names,
    within.x.names = within.x.names,
    within.y.names = within.y.names,
    between.names = between.names,
    between.x.names = between.x.names,
    between.y.names = between.y.names
  )

  out
}

lav_lavaan_step15_baseline <- function(lavoptions = NULL,
                                       lavsamplestats = NULL,
                                       lavdata = NULL,
                                       lavcache = NULL,
                                       lavh1 = NULL,
                                       lavpartable = NULL) {
  # # # # # # # # # # #
  # #  15. baseline # #  (since 0.6-5)
  # # # # # # # # # # #

  # if options$do.fit and options$test not "none" and options$baseline = TRUE
  #   try fit.indep <- lav_object_independence(...)
  #   if not succesfull or not converged
  #     ** warning **
  #     lavbaseline < list()
  #   else
  #     lavbaseline <- list with partable and test of fit.indep
  lavbaseline <- list()
  if (lavoptions$do.fit &&
    !("none" %in% lavoptions$test) &&
    is.logical(lavoptions$baseline) && lavoptions$baseline) {
    if (lav_verbose()) {
      cat("lavbaseline ...")
    }
	current.verbose <- lav_verbose()
	lav_verbose(FALSE)
    fit.indep <- try(lav_object_independence(
      object = NULL,
      lavsamplestats = lavsamplestats,
      lavdata = lavdata,
      lavcache = lavcache,
      lavoptions = lavoptions,
      lavpartable = lavpartable,
      lavh1 = lavh1
    ), silent = TRUE)
	lav_verbose(current.verbose)
    if (inherits(fit.indep, "try-error") || !fit.indep@optim$converged) {
      lav_msg_warn(gettext("estimation of the baseline model failed."))
      lavbaseline <- list()
      if (lav_verbose()) {
        cat(" FAILED.\n")
      }
    } else {
      # store relevant information
      lavbaseline <- list(
        partable = fit.indep@ParTable,
        test = fit.indep@test
      )
      if (lav_verbose()) {
        cat(" done.\n")
      }
    }
  }

  lavbaseline
}

# Gauss-Newton style optimization
#
# Initial version needed for DLS - model based
# YR - 19 Jan 2021
#
# TODo:
# - what to do if the function value goes up?
# - handle general (nonlinear) equality constraints
# - handle general (nonlinear) inequality constraints
# - better approach for simple bounds
# ...

# YR - 04 Nov 2023: add huber = TRUE option to get 'outlier-robust' estimates
#      (see Yuan and Zhong 2008, where they call this IRLS_r)


# objective function, plus 'extra' information
# needed for a Gauss Newton step
lav_objective_GN <- function(x, lavsamplestats = NULL, lavmodel = NULL,
                             lavoptions = NULL, lavdata = NULL,
                             extra = FALSE, lambda = NULL) {
  # evaluate objective function
  lavmodel <- lav_model_set_parameters(lavmodel = lavmodel, x = x)
  obj <- lav_model_objective(
    lavmodel = lavmodel, lavdata = lavdata,
    lavsamplestats = lavsamplestats
  )
  attributes(obj) <- NULL

  # monitoring obj only
  if (!extra) {
    # handle linear equality constraints
    if (lavmodel@eq.constraints) {
      hx <- lavmodel@ceq.function(x)
      obj <- obj + max(abs(lambda)) * sum(abs(hx))
    }
    return(list(obj = obj, U.invQ = NULL, lambda = lambda))
  }

  # model implied statistics
  lavimplied <- lav_model_implied(lavmodel = lavmodel)
  wls.est <- lav_model_wls_est(lavmodel = lavmodel, lavimplied = lavimplied)

  # observed statistics
  wls.obs <- lavsamplestats@WLS.obs

  # always use expected information
  A1 <- lav_model_h1_information_expected(
    lavobject = NULL,
    lavmodel = lavmodel,
    lavsamplestats = lavsamplestats,
    lavdata = lavdata,
    lavoptions = lavoptions,
    lavimplied = lavimplied,
    lavh1 = NULL,
    lavcache = NULL
  )
  # Delta
  Delta <- lav_model_delta(lavmodel = lavmodel)

  # first group
  g <- 1L
  if (lavmodel@estimator == "DWLS") {
    PRE.g <- t(Delta[[g]] * A1[[g]])
  } else {
    PRE.g <- t(Delta[[g]]) %*% A1[[g]]
  }
  Q.g <- PRE.g %*% (wls.obs[[g]] - wls.est[[g]])
  U.g <- PRE.g %*% Delta[[g]]

  # additional groups (if any)
  if (lavsamplestats@ngroups > 1L) {
    fg <- lavsamplestats@nobs[[1]] / lavsamplestats@ntotal
    Q <- fg * Q.g
    U <- fg * U.g

    for (g in 2:lavsamplestats@ngroups) {
      fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal
      if (lavmodel@estimator == "DWLS") {
        PRE.g <- t(Delta[[g]] * A1[[g]])
      } else {
        PRE.g <- t(Delta[[g]]) %*% A1[[g]]
      }
      Q.g <- PRE.g %*% (wls.obs[[g]] - wls.est[[g]])
      U.g <- PRE.g %*% Delta[[g]]

      Q <- Q + fg * Q.g
      U <- U + fg * U.g
    }
  } else {
    Q <- Q.g
    U <- U.g
  }

  # handle equality constraints
  # this can be made more efficient; see Jamshidian & Bentler 1993
  # where instead of inverting a p+r matrix, they use a p-r matrix
  # (if the eq constraints are linear)
  if (lavmodel@eq.constraints) {
    hx <- lavmodel@ceq.function(x)
    npar <- nrow(U)
    H <- lavmodel@con.jac
    U <- U + crossprod(H)
    U <- rbind(
      cbind(U, t(H)),
      cbind(H, matrix(0, nrow(H), nrow(H)))
    )
    Q <- rbind(Q, matrix(-hx, nrow(H), 1))
  }

  # compute step
  # note, we could use U + k*I for a given scalar 'k' (Levenberg, 1944)
  #                 or U + k*(diag(U) (Marquardt, 1963)
  U.invQ <- drop(solve(U, Q))
  if (lavmodel@eq.constraints) {
    # merit function
    lambda <- U.invQ[-seq_len(npar)]
    obj <- obj + max(abs(lambda)) * sum(abs(hx))
  } else {
    lambda <- NULL
  }

  list(obj = obj, U.invQ = U.invQ, lambda = lambda)
}

lav_optim_gn <- function(lavmodel = NULL, lavsamplestats = NULL,
                         lavpartable = NULL,
                         lavdata = NULL, lavoptions = NULL) {
  # no support (yet) for nonlinear constraints
  nonlinear.idx <- c(
    lavmodel@ceq.nonlinear.idx,
    lavmodel@cin.nonlinear.idx
  )
  if (length(nonlinear.idx) > 0L) {
    lav_msg_stop(gettext(
      "nonlinear constraints not supported (yet) with optim.method = \"GN\"."))
  }

  # no support (yet) for inequality constraints
  if (!is.null(body(lavmodel@cin.function))) {
    lav_msg_stop(gettext(
      "inequality constraints not supported (yet) with optim.method = \"GN\"."))
  }

  # extract current set of free parameters
  x <- lav_model_get_parameters(lavmodel)
  npar <- length(x)

  # extract bounds (if any)
  lb <- ub <- NULL
  if (!is.null(lavpartable) && !is.null(lavpartable$lower)) {
    lb <- lavpartable$lower[lavpartable$free > 0]
    stopifnot(length(x) == length(lb))
    lb.idx <- which(x < lb)
    if (length(lb.idx) > 0L) {
      x[lb.idx] <- lb[lb.idx]
    }
  }
  if (!is.null(lavpartable) && !is.null(lavpartable$upper)) {
    ub <- lavpartable$upper[lavpartable$free > 0]
    stopifnot(length(x) == length(ub))
    ub.idx <- which(x > ub)
    if (length(ub.idx) > 0L) {
      x[ub.idx] <- ub[ub.idx]
    }
  }

  # options
  iter.max <- lavoptions$optim.gn.iter.max
  tol.x <- lavoptions$optim.gn.tol.x
  stephalf.max <- as.integer(lavoptions$optim.gn.stephalf.max)
  if (stephalf.max < 0L) {
    stephalf.max <- 0L
  }

  # initialize
  iter <- 0
  alpha <- 1.0
  old.x <- x

  # start Gauss-Newton steps
  for (iter in seq_len(iter.max)) {
    old.out <- lav_objective_GN(
      x = old.x, lavsamplestats = lavsamplestats,
      lavoptions = lavoptions, lavdata = lavdata,
      lavmodel = lavmodel, extra = TRUE
    )
    old.obj <- old.out$obj
    U.invQ <- old.out$U.invQ

    # only the first time
    if (lav_verbose() && iter == 1L) {
      cat("iteration = ", sprintf("%2d", iter - 1L),
        ": objective = ", sprintf("%11.9f", old.obj), "\n",
        sep = ""
      )
    }

    # update
    alpha <- 1.0
    step <- U.invQ[seq_len(npar)]
    # TODO: if step-halving fails, we could also
    # allow the steps to be negative
    for (h in 1:max(1L, stephalf.max)) {
      new.x <- old.x + (alpha * step)

      # apply simple bounds (if any)
      if (!is.null(lb)) {
        lb.idx <- which(new.x < lb)
        if (length(lb.idx) > 0L) {
          new.x[lb.idx] <- lb[lb.idx]
        }
      }
      if (!is.null(ub)) {
        ub.idx <- which(new.x > ub)
        if (length(ub.idx) > 0L) {
          new.x[ub.idx] <- ub[ub.idx]
        }
      }

      new.obj <- lav_objective_GN(
        x = new.x,
        lavsamplestats = lavsamplestats,
        lavdata = lavdata, lavoptions = lavoptions,
        lavmodel = lavmodel, extra = FALSE,
        lambda = old.out$lambda
      )$obj

      if (is.finite(new.obj) && new.obj < old.obj) {
        break
      } else if (stephalf.max == 0L) { # no step-halving!
        break
      } else {
        # step-halving
        alpha <- alpha / 2.0
        # if(verbose) {
        #    cat(" -- step halving -- : alpha = ", alpha, "\n")
        # }
      }
    }

    # TODO - if this fails, we need to recover somehow
    # negative steps:
    if (stephalf.max != 0L && h == stephalf.max) {
      if (lav_verbose()) {
        cat(" -- step halving failed; function value may increase.\n")
      }
      # forcing step with alpha = 1
      new.x <- old.x + (1 * step)
    }

    rms.x <- sqrt(mean((old.x - new.x) * (old.x - new.x)))

    # verbose?
    if (lav_verbose()) {
      cat("iteration = ", sprintf("%2d", iter),
        ": objective = ", sprintf("%11.9f", new.obj),
        " alpha = ", sprintf("%6.5f", alpha),
        " rms.x = ", sprintf("%9.9f", rms.x), "\n",
        sep = ""
      )
      # print(new.x)
    }

    # check for convergence
    if (rms.x < tol.x) {
      old.x <- new.x
      old.obj <- new.obj
      if (lav_verbose()) {
        cat("Gauss-Newton algorithm converged: rms.x = ",
          sprintf("%12.12f", rms.x), " < ",
          sprintf("%12.12f", tol.x), "\n",
          sep = ""
        )
      }
      break
    } else {
      old.x <- new.x
      old.obj <- new.obj
    }
  } # iter

  x <- new.x

  # one last evaluation, to get fx.group attribute
  lavmodel <- lav_model_set_parameters(lavmodel = lavmodel, x = x)
  fx <- lav_model_objective(
    lavmodel = lavmodel, lavdata = lavdata,
    lavsamplestats = lavsamplestats
  )

  # add attributes
  if (iter < iter.max) {
    attr(x, "converged") <- TRUE
    attr(x, "warn.txt") <- ""
  } else {
    attr(x, "converged") <- FALSE
    attr(x, "warn.txt") <- paste("maxmimum number of iterations (",
      iter.max, ") ",
      "was reached without convergence.\n",
      sep = ""
    )
  }
  attr(x, "iterations") <- iter
  attr(x, "control") <- list(
    iter.max = iter.max,
    tol.x = tol.x
  )
  attr(x, "fx") <- fx

  x
}

# functions related to CFI and other 'incremental' fit indices

# lower-level functions:
# - lav_fit_cfi
# - lav_fit_rni (same as CFI, but without the max(0,))
# - lav_fit_tli/lav_fit_nnfi
# - lav_fit_rfi
# - lav_fit_nfi
# - lav_fit_pnfi
# - lav_fit_ifi

# higher-level functions:
# - lav_fit_cfi_lavobject

# Y.R. 20 July 2022

# CFI - comparative fit index (Bentler, 1990)
# robust version: Brosseau-Liard & Savalei MBR 2014, equation 15
# Brosseau-Liard, P. E., & Savalei, V. (2014). Adjusting incremental fit
# indices for nonnormality. Multivariate behavioral research, 49(5), 460-470.

# robust version MLMV (scaled.shifted)
# Savalei, V. (2018). On the computation of the RMSEA and CFI from the
# mean-and-variance corrected test statistic with nonnormal data in SEM.
# Multivariate behavioral research, 53(3), 419-429. eq 9

# note: robust MLM == robust MLMV

# categorical data:
# Savalei, V. (2021). Improving fit indices in structural equation modeling with
# categorical data. Multivariate Behavioral Research, 56(3), 390-407. doi:
# 10.1080/00273171.2020.1717922

# when missing = "fiml":
# Zhang, X., & Savalei, V. (2023). New computations for RMSEA and CFI following
# FIML and TS estimation with missing data. Psychological Methods, 28(2),
# 263-283. https://doi.org/10.1037/met0000445


lav_fit_cfi <- function(X2 = NULL, df = NULL, X2.null = NULL, df.null = NULL,
                        c.hat = 1, c.hat.null = 1) {
  if (anyNA(c(X2, df, X2.null, df.null, c.hat, c.hat.null))) {
    return(as.numeric(NA))
  }

  # robust?
  if (df > 0 && !missing(c.hat) && !missing(c.hat.null) &&
    c.hat != 1 && c.hat.null != 1) {
    t1 <- max(c(X2 - (c.hat * df), 0))
    t2 <- max(c(X2 - (c.hat * df), X2.null - (c.hat.null * df.null), 0))
  } else {
    t1 <- max(c(X2 - df, 0))
    t2 <- max(c(X2 - df, X2.null - df.null, 0))
  }

  if (isTRUE(all.equal(t1, 0)) && isTRUE(all.equal(t2, 0))) {
    CFI <- 1
  } else {
    CFI <- 1 - t1 / t2
  }

  CFI
}

# RNI - relative noncentrality index (McDonald & Marsh, 1990)
# same as CFI, but without the max(0,)
lav_fit_rni <- function(X2 = NULL, df = NULL, X2.null = NULL, df.null = NULL,
                        c.hat = 1, c.hat.null = 1) {
  if (anyNA(c(X2, df, X2.null, df.null, c.hat, c.hat.null))) {
    return(as.numeric(NA))
  }

  # robust?
  if (df > 0 && !missing(c.hat) && !missing(c.hat.null) &&
    c.hat != 1 && c.hat.null != 1) {
    t1 <- X2 - (c.hat * df)
    t2 <- X2.null - (c.hat.null * df.null)
  } else {
    t1 <- X2 - df
    t2 <- X2.null - df.null
  }

  if (isTRUE(all.equal(t2, 0))) {
    RNI <- as.numeric(NA)
  } else if (!is.finite(t1) || !is.finite(t2)) {
    RNI <- as.numeric(NA)
  } else {
    RNI <- 1 - t1 / t2
  }

  RNI
}

# TLI - Tucker-Lewis index (Tucker & Lewis, 1973)
# same as
# NNFI - nonnormed fit index (NNFI, Bentler & Bonett, 1980)
# note: formula in lavaan <= 0.5-20:
# t1 <- X2.null/df.null - X2/df
# t2 <- X2.null/df.null - 1
# if(t1 < 0 && t2 < 0) {
#    TLI <- 1
# } else {
#    TLI <- t1/t2
# }
# note: TLI original formula was in terms of fx/df, not X2/df
# then, t1 <- fx_0/df.null - fx/df
#       t2 <- fx_0/df.null - 1/N (or N-1 for wishart)

# note: in lavaan 0.5-21, we use the alternative formula:
# TLI <- 1 - ((X2 - df)/(X2.null - df.null) * df.null/df)
# - this one has the advantage that a 'robust' version
#   can be derived; this seems non-trivial for the original one
# - unlike cfi, we do not use 'max(0, )' for t1 and t2
#   therefore, t1 can go negative, and TLI can be > 1
lav_fit_tli <- function(X2 = NULL, df = NULL, X2.null = NULL, df.null = NULL,
                        c.hat = 1, c.hat.null = 1) {
  if (anyNA(c(X2, df, X2.null, df.null, c.hat, c.hat.null))) {
    return(as.numeric(NA))
  }

  # robust?
  if (df > 0 && !missing(c.hat) && !missing(c.hat.null) &&
    c.hat != 1 && c.hat.null != 1) {
    t1 <- (X2 - c.hat * df) * df.null
    t2 <- (X2.null - c.hat.null * df.null) * df
  } else {
    t1 <- (X2 - df) * df.null
    t2 <- (X2.null - df.null) * df
  }

  if (df > 0 && abs(t2) > 0) {
    TLI <- 1 - t1 / t2
  } else if (!is.finite(t1) || !is.finite(t2)) {
    TLI <- as.numeric(NA)
  } else {
    TLI <- 1
  }

  TLI
}

# alias for nnfi
lav_fit_nnfi <- lav_fit_tli

# RFI - relative fit index (Bollen, 1986; Joreskog & Sorbom 1993)
lav_fit_rfi <- function(X2 = NULL, df = NULL, X2.null = NULL, df.null = NULL) {
  if (anyNA(c(X2, df, X2.null, df.null))) {
    return(as.numeric(NA))
  }

  if (df > df.null) {
    RLI <- as.numeric(NA)
  } else if (df > 0 && df.null > 0) {
    t1 <- X2.null / df.null - X2 / df
    t2 <- X2.null / df.null
    if (!is.finite(t1) || !is.finite(t2)) {
      RLI <- as.numeric(NA)
    } else if (t1 < 0 || t2 < 0) {
      RLI <- 1
    } else {
      RLI <- t1 / t2
    }
  } else {
    RLI <- 1
  }

  RLI
}

# NFI - normed fit index (Bentler & Bonett, 1980)
lav_fit_nfi <- function(X2 = NULL, df = NULL, X2.null = NULL, df.null = NULL) {
  if (anyNA(c(X2, df, X2.null, df.null))) {
    return(as.numeric(NA))
  }

  if (df > df.null || isTRUE(all.equal(X2.null, 0))) {
    NFI <- as.numeric(NA)
  } else if (df > 0) {
    t1 <- X2.null - X2
    t2 <- X2.null
    NFI <- t1 / t2
  } else {
    NFI <- 1
  }

  NFI
}

# PNFI - Parsimony normed fit index (James, Mulaik & Brett, 1982)
lav_fit_pnfi <- function(X2 = NULL, df = NULL, X2.null = NULL, df.null = NULL) {
  if (anyNA(c(X2, df, X2.null, df.null))) {
    return(as.numeric(NA))
  }

  if (df.null > 0 && X2.null > 0) {
    t1 <- X2.null - X2
    t2 <- X2.null
    PNFI <- (df / df.null) * (t1 / t2)
  } else {
    PNFI <- as.numeric(NA)
  }

  PNFI
}

# IFI - incremental fit index (Bollen, 1989; Joreskog & Sorbom, 1993)
lav_fit_ifi <- function(X2 = NULL, df = NULL, X2.null = NULL, df.null = NULL) {
  if (anyNA(c(X2, df, X2.null, df.null))) {
    return(as.numeric(NA))
  }

  t1 <- X2.null - X2
  t2 <- X2.null - df
  if (!is.finite(t1) || !is.finite(t2)) {
    IFI <- as.numeric(NA)
  } else if (t2 < 0) {
    IFI <- 1
  } else if (isTRUE(all.equal(t2, 0))) {
    IFI <- as.numeric(NA)
  } else {
    IFI <- t1 / t2
  }

  IFI
}

# higher-level function
lav_fit_cfi_lavobject <- function(lavobject = NULL, fit.measures = "cfi",
                                  baseline.model = NULL, h1.model = NULL,
                                  standard.test = "standard",
                                  scaled.test = "none",
                                  robust = TRUE,
                                  cat.check.pd = TRUE) {
  # check lavobject
  stopifnot(inherits(lavobject, "lavaan"))

  # check for categorical
  categorical.flag <- lavobject@Model@categorical

  # tests
  TEST <- lavobject@test
  test.names <- sapply(lavobject@test, "[[", "test")
  if (test.names[1] == "none" || standard.test == "none") {
    return(list())
  }
  test.idx <- which(test.names == standard.test)[1]
  if (length(test.idx) == 0L) {
    return(list())
  }

  scaled.flag <- FALSE
  if (!scaled.test %in% c("none", "standard", "default")) {
    scaled.idx <- which(test.names == scaled.test)
    if (length(scaled.idx) > 0L) {
      scaled.idx <- scaled.idx[1] # only the first one
      scaled.flag <- TRUE
    }
  }

  # robust?
  robust.flag <- FALSE
  if (robust && scaled.flag &&
    scaled.test %in% c(
      "satorra.bentler", "yuan.bentler.mplus",
      "yuan.bentler", "scaled.shifted"
    )) {
    robust.flag <- TRUE
  }

  # FIML?
  fiml.flag <- FALSE
  if (robust && lavobject@Options$missing %in% c("ml", "ml.x")) {
    fiml.flag <- robust.flag <- TRUE
    # check if we can compute corrected values
    if (scaled.flag) {
      version <- "V3"
    } else {
      version <- "V6"
    }
    fiml <- try(
      lav_fit_fiml_corrected(lavobject, baseline.model,
        version = version
      ),
      silent = TRUE
    )
    if (inherits(fiml, "try-error")) {
      lav_msg_warn(gettext("computation of robust CFI failed."))
      fiml <- list(
        XX3 = as.numeric(NA), df3 = as.numeric(NA),
        c.hat3 = as.numeric(NA), XX3.scaled = as.numeric(NA),
        XX3.null = as.numeric(NA), df3.null = as.numeric(NA),
        c.hat3.null = as.numeric(NA)
      )
    } else if (anyNA(c(
      fiml$XX3, fiml$df3, fiml$c.hat3, fiml$XX3.scaled,
      fiml$XX3.null, fiml$df3.null, fiml$c.hat3.null
    ))) {
      lav_msg_warn(gettext("computation of robust CFI resulted in NA values."))
    }
  }

  # supported fit measures in this function
  # baseline model
  fit.baseline <- c("baseline.chisq", "baseline.df", "baseline.pvalue")
  if (scaled.flag) {
    fit.baseline <- c(
      fit.baseline, "baseline.chisq.scaled",
      "baseline.df.scaled", "baseline.pvalue.scaled",
      "baseline.chisq.scaling.factor"
    )
  }

  fit.cfi.tli <- c("cfi", "tli")
  if (scaled.flag) {
    fit.cfi.tli <- c(fit.cfi.tli, "cfi.scaled", "tli.scaled")
  }
  if (robust.flag) {
    fit.cfi.tli <- c(fit.cfi.tli, "cfi.robust", "tli.robust")
  }

  # other incremental fit indices
  fit.cfi.other <- c("nnfi", "rfi", "nfi", "pnfi", "ifi", "rni")
  if (scaled.flag) {
    fit.cfi.other <- c(
      fit.cfi.other, "nnfi.scaled", "rfi.scaled",
      "nfi.scaled", "pnfi.scaled", "ifi.scaled", "rni.scaled"
    )
  }
  if (robust.flag) {
    fit.cfi.other <- c(fit.cfi.other, "nnfi.robust", "rni.robust")
  }

  # which one do we need?
  if (missing(fit.measures)) {
    # default set
    fit.measures <- c(fit.baseline, fit.cfi.tli)
  } else {
    # remove any not-CFI related index from fit.measures
    rm.idx <- which(!fit.measures %in%
      c(fit.baseline, fit.cfi.tli, fit.cfi.other))
    if (length(rm.idx) > 0L) {
      fit.measures <- fit.measures[-rm.idx]
    }
    if (length(fit.measures) == 0L) {
      return(list())
    }
  }


  # basic test statistics
  X2 <- TEST[[test.idx]]$stat
  df <- TEST[[test.idx]]$df
  G <- lavobject@Data@ngroups # number of groups
  N <- lav_object_inspect_ntotal(object = lavobject) # N vs N-1

  # scaled X2
  if (scaled.flag) {
    X2.scaled <- TEST[[scaled.idx]]$stat
    df.scaled <- TEST[[scaled.idx]]$df
  }
  if (robust.flag) {
    XX3 <- X2
    if (categorical.flag) {
      out <- try(lav_fit_catml_dwls(lavobject, check.pd = cat.check.pd),
        silent = TRUE
      )
      if (inherits(out, "try-error")) {
        XX3 <- df3 <- c.hat <- c.hat3 <- XX3.scaled <- as.numeric(NA)
      } else {
        XX3 <- out$XX3
        df3 <- out$df3
        c.hat3 <- c.hat <- out$c.hat3
        XX3.scaled <- out$XX3.scaled
      }
    } else if (fiml.flag) {
      XX3 <- fiml$XX3
      df3 <- fiml$df3
      c.hat3 <- c.hat <- fiml$c.hat3
      XX3.scaled <- fiml$XX3.scaled
    } else if (scaled.test == "scaled.shifted") {
      # compute c.hat from a and b
      a <- TEST[[scaled.idx]]$scaling.factor
      b <- TEST[[scaled.idx]]$shift.parameter
      c.hat <- a * (df - b) / df
    } else {
      c.hat <- TEST[[scaled.idx]]$scaling.factor
    }
  }

  # output container
  indices <- list()

  # only do what is needed (per groups)
  cfi.baseline.flag <- cfi.tli.flag <- cfi.other.flag <- FALSE
  if (any(fit.baseline %in% fit.measures)) {
    cfi.baseline.flag <- TRUE
  }
  if (any(fit.cfi.tli %in% fit.measures)) {
    cfi.tli.flag <- TRUE
  }
  if (any(fit.cfi.other %in% fit.measures)) {
    cfi.other.flag <- TRUE
  }

  # 1. BASELINE model
  baseline.test <- NULL

  # we use the following priority:
  # 1. user-provided baseline model
  # 2. baseline model in @external slot
  # 3. baseline model in @baseline slot
  # 4. nothing -> compute independence model

  # TDJ: Also check for user-supplied h1.model, using similar priority:
  #        1. user-provided h1 model
  #        2. h1 model in @external slot
  #        3. default h1 model (already in @h1 slot, no update necessary)

  # 1. user-provided h1 model
  if (!is.null(h1.model)) {
    stopifnot(inherits(h1.model, "lavaan"))

    # 2. h1 model in @external slot
  } else if (!is.null(lavobject@external$h1.model)) {
    stopifnot(inherits(lavobject@external$h1.model, "lavaan"))
    h1.model <- lavobject@external$h1.model
  } # else is.null

  # 1. user-provided baseline model
  if (!is.null(baseline.model)) {
    baseline.test <-
      lav_fit_measures_check_baseline(
        fit.indep = baseline.model,
        object = lavobject,
        fit.h1 = h1.model # okay if NULL
      )
    # 2. baseline model in @external slot
  } else if (!is.null(lavobject@external$baseline.model)) {
    fit.indep <- lavobject@external$baseline.model
    baseline.test <-
      lav_fit_measures_check_baseline(
        fit.indep = fit.indep,
        object = lavobject,
        fit.h1 = h1.model # okay if NULL
      )
    # 3. internal @baseline slot
  } else if (length(lavobject@baseline) > 0L &&
    !is.null(lavobject@baseline$test) &&
    ## if there is a custom h1.model, need  _check_baseline() to update @test
    is.null(h1.model)) {
    baseline.test <- lavobject@baseline$test
    # 4. (re)compute independence model
  } else {
    fit.indep <- try(lav_object_independence(lavobject), silent = TRUE)
    baseline.test <-
      lav_fit_measures_check_baseline(
        fit.indep = fit.indep,
        object = lavobject,
        fit.h1 = h1.model # okay if NULL
      )
  }

  # baseline.test.idx
  baseline.test.idx <- which(names(baseline.test) == standard.test)[1]
  if (scaled.flag) {
    baseline.scaled.idx <- which(names(baseline.test) == scaled.test)[1]
  }

  if (!is.null(baseline.test)) {
    X2.null <- baseline.test[[baseline.test.idx]]$stat
    df.null <- baseline.test[[baseline.test.idx]]$df
    if (scaled.flag) {
      X2.null.scaled <- baseline.test[[baseline.scaled.idx]]$stat
      df.null.scaled <- baseline.test[[baseline.scaled.idx]]$df
    }
    if (robust.flag) {
      XX3.null <- X2.null
      if (categorical.flag) {
        if (inherits(out, "try-error")) {
          XX3.null <- c.hat.null <- as.numeric(NA)
        } else {
          XX3.null <- out$XX3.null
          c.hat.null <- out$c.hat3.null
        }
      } else if (fiml.flag) {
        XX3.null <- fiml$XX3.null
        c.hat.null <- fiml$c.hat3.null
      } else if (scaled.test == "scaled.shifted") {
        # compute c.hat from a and b
        a.null <-
          baseline.test[[baseline.scaled.idx]]$scaling.factor
        b.null <-
          baseline.test[[baseline.scaled.idx]]$shift.parameter
        c.hat.null <- a.null * (df.null - b.null) / df.null
      } else {
        c.hat.null <-
          baseline.test[[baseline.scaled.idx]]$scaling.factor
      }
    }
  } else {
    X2.null <- df.null <- as.numeric(NA)
    X2.null.scaled <- df.null.scaled <- as.numeric(NA)
    c.hat.null <- as.numeric(NA)
  }

  # check for NAs of nonfinite numbers
  if (!is.finite(X2) || !is.finite(df) ||
    !is.finite(X2.null) || !is.finite(df.null)) {
    indices[fit.measures] <- as.numeric(NA)
    return(indices)
  }

  # fill in baseline indices
  if (cfi.baseline.flag) {
    indices["baseline.chisq"] <- X2.null
    indices["baseline.df"] <- df.null
    indices["baseline.pvalue"] <- baseline.test[[baseline.test.idx]]$pvalue
    if (scaled.flag) {
      indices["baseline.chisq.scaled"] <- X2.null.scaled
      indices["baseline.df.scaled"] <- df.null.scaled
      indices["baseline.pvalue.scaled"] <-
        baseline.test[[baseline.scaled.idx]]$pvalue
      indices["baseline.chisq.scaling.factor"] <-
        baseline.test[[baseline.scaled.idx]]$scaling.factor
    }
  }

  # 2. CFI and TLI
  if (cfi.tli.flag) {
    indices["cfi"] <- lav_fit_cfi(
      X2 = X2, df = df,
      X2.null = X2.null, df.null = df.null
    )
    indices["tli"] <- lav_fit_tli(
      X2 = X2, df = df,
      X2.null = X2.null, df.null = df.null
    )
    if (scaled.flag) {
      indices["cfi.scaled"] <-
        lav_fit_cfi(
          X2 = X2.scaled, df = df.scaled,
          X2.null = X2.null.scaled, df.null = df.null.scaled
        )
      indices["tli.scaled"] <-
        lav_fit_tli(
          X2 = X2.scaled, df = df.scaled,
          X2.null = X2.null.scaled, df.null = df.null.scaled
        )
    }
    if (robust.flag) {
      indices["cfi.robust"] <-
        lav_fit_cfi(
          X2 = XX3, df = df,
          X2.null = XX3.null, df.null = df.null,
          c.hat = c.hat, c.hat.null = c.hat.null
        )
      indices["tli.robust"] <-
        lav_fit_tli(
          X2 = XX3, df = df,
          X2.null = XX3.null, df.null = df.null,
          c.hat = c.hat, c.hat.null = c.hat.null
        )
    }
  }

  # 3. other
  # c("nnfi", "rfi", "nfi", "pnfi", "ifi", "rni")
  if (cfi.other.flag) {
    indices["nnfi"] <-
      lav_fit_nnfi(X2 = X2, df = df, X2.null = X2.null, df.null = df.null)
    indices["rfi"] <-
      lav_fit_rfi(X2 = X2, df = df, X2.null = X2.null, df.null = df.null)
    indices["nfi"] <-
      lav_fit_nfi(X2 = X2, df = df, X2.null = X2.null, df.null = df.null)
    indices["pnfi"] <-
      lav_fit_pnfi(X2 = X2, df = df, X2.null = X2.null, df.null = df.null)
    indices["ifi"] <-
      lav_fit_ifi(X2 = X2, df = df, X2.null = X2.null, df.null = df.null)
    indices["rni"] <-
      lav_fit_rni(X2 = X2, df = df, X2.null = X2.null, df.null = df.null)

    if (scaled.flag) {
      indices["nnfi.scaled"] <-
        lav_fit_nnfi(
          X2 = X2.scaled, df = df.scaled,
          X2.null = X2.null.scaled, df.null = df.null.scaled
        )
      indices["rfi.scaled"] <-
        lav_fit_rfi(
          X2 = X2.scaled, df = df.scaled,
          X2.null = X2.null.scaled, df.null = df.null.scaled
        )
      indices["nfi.scaled"] <-
        lav_fit_nfi(
          X2 = X2.scaled, df = df.scaled,
          X2.null = X2.null.scaled, df.null = df.null.scaled
        )
      indices["pnfi.scaled"] <-
        lav_fit_pnfi(
          X2 = X2.scaled, df = df.scaled,
          X2.null = X2.null.scaled, df.null = df.null.scaled
        )
      indices["ifi.scaled"] <-
        lav_fit_ifi(
          X2 = X2.scaled, df = df.scaled,
          X2.null = X2.null.scaled, df.null = df.null.scaled
        )
      indices["rni.scaled"] <-
        lav_fit_rni(
          X2 = X2.scaled, df = df.scaled,
          X2.null = X2.null.scaled, df.null = df.null.scaled
        )
    }
    if (robust.flag) {
      indices["nnfi.robust"] <-
        lav_fit_nnfi(
          X2 = XX3, df = df,
          X2.null = XX3.null, df.null = df.null,
          c.hat = c.hat, c.hat.null = c.hat.null
        )
      indices["rni.robust"] <-
        lav_fit_rni(
          X2 = XX3, df = df,
          X2.null = XX3.null, df.null = df.null,
          c.hat = c.hat, c.hat.null = c.hat.null
        )
    }
  }

  # return only those that were requested
  indices[fit.measures]
}


# new in 0.6-5
# internal function to check the (external) baseline model, and
# return baseline 'test' list if everything checks out (and NULL otherwise)
lav_fit_measures_check_baseline <- function(fit.indep = NULL, object = NULL,
                                            fit.h1 = NULL) {
  TEST <- NULL

  # check if everything is in order
  if (inherits(fit.indep, "try-error")) {
    lav_msg_warn(gettext("baseline model estimation failed"))
    return(NULL)
  } else if (!inherits(fit.indep, "lavaan")) {
    lav_msg_warn(gettext(
      "(user-provided) baseline model is not a fitted lavaan object"
    ))
    return(NULL)
  } else if (!fit.indep@optim$converged) {
    lav_msg_warn(gettext("baseline model did not converge"))
    return(NULL)
  } else {
    # evaluate if estimator/test matches original object
    # note: we do not need to check for 'se', as it may be 'none'
    sameTest <- all(object@Options$test == fit.indep@Options$test)
    if (!sameTest) {
      lav_msg_warn(gettextf(
        "Baseline model was using test(s) = %1$s, but original model was using
        test(s) = %2$s. Refitting baseline model!",
        lav_msg_view(fit.indep@Options$test, "none"),
        lav_msg_view(object@Options$test, "none")
      ))
    }
    sameEstimator <- (object@Options$estimator ==
      fit.indep@Options$estimator)
    if (!sameEstimator) {
      lav_msg_warn(gettextf(
        "Baseline model was using estimator = %1$s, but original model was
        using estimator = %2$s. Refitting baseline model!",
        dQuote(fit.indep@Options$estimator),
        dQuote(object@Options$estimator)
      ))
    }
    if (!sameTest || !sameEstimator) {
      lavoptions <- object@Options
      lavoptions$estimator <- object@Options$estimator
      lavoptions$se <- "none"
      lavoptions$baseline <- FALSE
      lavoptions$check.start <- FALSE
      lavoptions$check.post <- FALSE
      lavoptions$check.vcov <- FALSE
      lavoptions$test <- object@Options$test
      fit.indep <- try(
        lavaan(fit.indep,
          slotOptions = lavoptions,
          slotData = object@Data,
          slotSampleStats = object@SampleStats,
          sloth1 = object@h1,
          slotCache = object@Cache,
          verbose = FALSE
        ),
        silent = TRUE
      )
      # try again
      TEST <- lav_fit_measures_check_baseline(
        fit.indep = fit.indep,
        object = object
      )
    } else {
      # extract what we need
      TEST <- fit.indep@test
    }
  } # converged lavaan object



  # TDJ: Check for user-supplied h1.model (here, the fit.h1= argument)
  #      Similar to BASELINE model, use the following priority:
  #        1. user-provided h1 model
  #        2. h1 model in @external slot
  #        3. default h1 model (already in @h1 slot, no update necessary)
  # FIXME? user-supplied h1 model in object might be in fit.indep, too

  user_h1_exists <- FALSE
  # 1. user-provided h1 model
  if (!is.null(fit.h1)) {
    stopifnot(inherits(fit.h1, "lavaan"))
    user_h1_exists <- TRUE

    # 2. h1 model in @external slot
  } else if (!is.null(object@external$h1.model)) {
    stopifnot(inherits(object@external$h1.model, "lavaan"))
    fit.h1 <- object@external$h1.model
    user_h1_exists <- TRUE
  }

  if (user_h1_exists) {
    ## update @test slot
    TEST <- lav_update_test_custom_h1(
      lav_obj_h0 = fit.indep,
      lav_obj_h1 = fit.h1
    )@test
  }

  TEST
}

# the multivariate normal distribution

# 1) loglikelihood (from raw data, or sample statistics)
# 2) derivatives with respect to mu, Sigma, vech(Sigma)
# 3) casewise scores with respect to mu, vech(Sigma), mu + vech(Sigma)
# 4) hessian mu + vech(Sigma)
# 5) information h0 mu + vech(Sigma)
#    5a: (unit)    expected information
#    5b: (unit)    observed information
#    5c: (unit) first.order information
# 6) inverted information h0 mu + vech(Sigma)
#    6a: (unit) inverted expected information
#    6b: /
#    6c: /
# 7) ACOV h0 mu + vech(Sigma)
#    7a: 1/N * inverted expected    information
#    7b: 1/N * inverted observed    information
#    7c: 1/N * inverted first-order information
#    7d: sandwich acov

# YR 07 Feb 2016: first version
# YR 24 Mar 2016: added firstorder information, hessian logl
# YR 19 Jan 2017: added lav_mvnorm_inverted_information_expected
# YR 04 Okt 2018: adding wt= argument, and missing meanstructure=
# YR 27 Jun 2018: adding cluster.idx= argument for information_firstorder
# YR 24 Jul 2022: adding correlation= argument for information_expected
#                 (only for catml; not for correlation = TRUE!)

# 0. densities
lav_mvnorm_dmvnorm <- function(Y = NULL,
                               wt = NULL,
                               Mu = NULL,
                               Sigma = NULL,
                               Sigma.inv = NULL,
                               Sinv.method = "eigen",
                               x.idx = integer(0L),
                               x.mean = NULL,
                               x.cov = NULL,
                               log = TRUE) {
  if (is.matrix(Y)) {
    if (is.null(Mu) && is.null(Sigma) && is.null(Sigma.inv)) {
      out <- lav_mvnorm_loglik_data_z(Y = Y, casewise = TRUE)
    } else {
      out <- lav_mvnorm_loglik_data(
        Y = Y, Mu = Mu, Sigma = Sigma,
        casewise = TRUE,
        Sinv.method = Sinv.method
      )
    }
  } else {
    # just one
    P <- length(Y)
    LOG.2PI <- log(2 * pi)

    if (is.null(Mu) && is.null(Sigma) && is.null(Sigma.inv)) {
      # mahalanobis distance
      DIST <- sum(Y * Y)
      out <- -(P * LOG.2PI + DIST) / 2
    } else {
      if (is.null(Sigma.inv)) {
        Sigma.inv <- lav_matrix_symmetric_inverse(
          S = Sigma,
          logdet = TRUE, Sinv.method = Sinv.method
        )
        logdet <- attr(Sigma.inv, "logdet")
      } else {
        logdet <- attr(Sigma.inv, "logdet")
        if (is.null(logdet)) {
          # compute - ln|Sigma.inv|
          ev <- eigen(Sigma.inv, symmetric = TRUE, only.values = TRUE)
          logdet <- -1 * sum(log(ev$values))
        }
      }

      # mahalanobis distance
      Yc <- Y - Mu
      DIST <- sum(Yc %*% Sigma.inv * Yc)
      out <- -(P * LOG.2PI + logdet + DIST) / 2
    }
  }

  if (!is.null(wt)) {
    out <- out * wt
  }

  # x.idx?
  if (length(x.idx) > 0L) {
    if (is.null(Sigma) && is.null(x.cov)) {
      lav_msg_stop(gettext("when x.idx is not empty, we need Sigma or x.cov"))
    }
    if (is.matrix(Y)) {
      X <- Y[, x.idx, drop = FALSE]
    } else {
      X <- Y[x.idx]
    }

    Mu.X <- x.mean
    Sigma.X <- x.cov
    if (is.null(x.mean)) {
      Mu.X <- as.numeric(Mu)[x.idx]
    }
    if (is.null(x.cov)) {
      Sigma.X <- Sigma[x.idx, x.idx, drop = FALSE]
    }

    logl.X <- lav_mvnorm_dmvnorm(
      Y = X, wt = wt, Mu = Mu.X, Sigma = Sigma.X,
      Sigma.inv = NULL,
      Sinv.method = Sinv.method,
      x.idx = integer(0L), log = TRUE
    )

    # subtract logl.X
    out <- out - logl.X
  }

  if (!log) {
    out <- exp(out)
  }

  out
}

# 1. likelihood

# 1a: input is raw data
# (note casewise = TRUE same as: dmvnorm(Y, mean, sigma, log = TRUE))
lav_mvnorm_loglik_data <- function(Y = NULL,
                                   wt = NULL,
                                   Mu = NULL,
                                   Sigma = NULL,
                                   x.idx = integer(0L),
                                   x.mean = NULL,
                                   x.cov = NULL,
                                   casewise = FALSE,
                                   Sinv.method = "eigen") {
  # Y must be a matrix (use lav_mvnorm_dmvnorm() for non-matrix input)
  stopifnot(is.matrix(Y))

  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }

  P <- NCOL(Y)
  Mu <- as.numeric(Mu)

  if (casewise) {
    LOG.2PI <- log(2 * pi)

    # invert Sigma
    if (Sinv.method == "chol") {
      cS <- chol(Sigma)
      icS <- backsolve(cS, diag(P))
      Yc <- t(t(Y) - Mu)
      DIST <- rowSums((Yc %*% icS)^2)
      logdet <- -2 * sum(log(diag(icS)))
    } else {
      Sigma.inv <- lav_matrix_symmetric_inverse(
        S = Sigma, logdet = TRUE,
        Sinv.method = Sinv.method
      )
      logdet <- attr(Sigma.inv, "logdet")
      # mahalanobis distance
      Yc <- t(t(Y) - Mu)
      DIST <- rowSums(Yc %*% Sigma.inv * Yc)
    }

    loglik <- -(P * LOG.2PI + logdet + DIST) / 2

    # weights
    if (!is.null(wt)) {
      loglik <- loglik * wt
    }
  } else {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = TRUE,
      Sinv.method = Sinv.method
    )
    if (!is.null(wt)) {
      out <- stats::cov.wt(Y, wt = wt, method = "ML")
      sample.mean <- out$center
      sample.cov <- out$cov
    } else {
      sample.mean <- base::.colMeans(Y, m = N, n = P)
      sample.cov <- lav_matrix_cov(Y)
    }
    loglik <- lav_mvnorm_loglik_samplestats(
      sample.mean = sample.mean,
      sample.cov = sample.cov,
      sample.nobs = N,
      Mu = Mu,
      Sigma.inv = Sigma.inv
    )
  }

  # fixed.x?
  if (length(x.idx) > 0L) {
    Mu.X <- x.mean
    Sigma.X <- x.cov
    if (is.null(x.mean)) {
      Mu.X <- as.numeric(Mu)[x.idx]
    }
    if (is.null(x.cov)) {
      Sigma.X <- Sigma[x.idx, x.idx, drop = FALSE]
    }
    loglik.x <- lav_mvnorm_loglik_data(
      Y = Y[, x.idx, drop = FALSE],
      wt = wt, Mu = Mu.X, Sigma = Sigma.X,
      x.idx = integer(0L), casewise = casewise,
      Sinv.method = Sinv.method
    )
    # subtract logl.X
    loglik <- loglik - loglik.x
  }

  loglik
}



# 1b: input are sample statistics (mean, cov, N) only
lav_mvnorm_loglik_samplestats <- function(sample.mean = NULL,
                                          sample.cov = NULL,
                                          sample.nobs = NULL,
                                          Mu = NULL,
                                          Sigma = NULL,
                                          x.idx = integer(0L),
                                          x.mean = NULL,
                                          x.cov = NULL,
                                          Sinv.method = "eigen",
                                          Sigma.inv = NULL) {
  P <- length(sample.mean)
  N <- sample.nobs
  Mu <- as.numeric(Mu)
  sample.mean <- as.numeric(sample.mean)
  LOG.2PI <- log(2 * pi)

  if (is.null(Sigma.inv)) {
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = TRUE,
      Sinv.method = Sinv.method
    )
    logdet <- attr(Sigma.inv, "logdet")
  } else {
    logdet <- attr(Sigma.inv, "logdet")
    if (is.null(logdet)) {
      # compute - ln|Sigma.inv|
      ev <- eigen(Sigma.inv, symmetric = TRUE, only.values = TRUE)
      logdet <- -1 * sum(log(ev$values))
    }
  }

  # tr(Sigma^{-1} %*% S)
  DIST1 <- sum(Sigma.inv * sample.cov)
  # (ybar - mu)^T %*% Sigma.inv %*% (ybar - mu)
  Diff <- as.numeric(sample.mean - Mu)
  DIST2 <- sum(as.numeric(crossprod(Diff, Sigma.inv)) * Diff)

  loglik <- -N / 2 * (P * LOG.2PI + logdet + DIST1 + DIST2)

  # fixed.x?
  if (length(x.idx) > 0L) {
    Mu.X <- x.mean
    Sigma.X <- x.cov
    if (is.null(x.mean)) {
      Mu.X <- Mu[x.idx]
    }
    if (is.null(x.cov)) {
      Sigma.X <- Sigma[x.idx, x.idx, drop = FALSE]
    }
    sample.mean.x <- sample.mean[x.idx]
    sample.cov.x <- sample.cov[x.idx, x.idx, drop = FALSE]
    loglik.x <-
      lav_mvnorm_loglik_samplestats(
        sample.mean = sample.mean.x,
        sample.cov = sample.cov.x,
        sample.nobs = sample.nobs,
        Mu = Mu.X, Sigma = Sigma.X,
        x.idx = integer(0L),
        Sinv.method = Sinv.method
      )
    # subtract logl.X
    loglik <- loglik - loglik.x
  }

  loglik
}

# 1c special case: Mu = 0, Sigma = I
lav_mvnorm_loglik_data_z <- function(Y = NULL,
                                     wt = NULL,
                                     casewise = FALSE) {
  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }

  P <- NCOL(Y)
  LOG.2PI <- log(2 * pi)

  if (casewise) {
    DIST <- rowSums(Y * Y)
    loglik <- -(P * LOG.2PI + DIST) / 2
    if (!is.null(wt)) {
      loglik <- loglik * wt
    }
  } else {
    if (!is.null(wt)) {
      out <- stats::cov.wt(Y, wt = wt, method = "ML")
      sample.mean <- out$center
      sample.cov <- out$cov
    } else {
      sample.mean <- base::.colMeans(Y, m = N, n = P)
      sample.cov <- lav_matrix_cov(Y)
    }

    DIST1 <- sum(diag(sample.cov))
    DIST2 <- sum(sample.mean * sample.mean)

    loglik <- -N / 2 * (P * LOG.2PI + DIST1 + DIST2)
  }

  loglik
}





# 2. Derivatives

# 2a: derivative logl with respect to mu
lav_mvnorm_dlogl_dmu <- function(Y = NULL,
                                 wt = NULL,
                                 Mu = NULL,
                                 Sigma = NULL,
                                 x.idx = integer(0L),
                                 Sinv.method = "eigen",
                                 Sigma.inv = NULL) {
  Mu <- as.numeric(Mu)

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # substract 'Mu' from Y
  Yc <- t(t(Y) - Mu)

  # weights
  if (!is.null(wt)) {
    Yc <- Yc * wt
  }

  # derivative
  dmu <- as.numeric(Sigma.inv %*% colSums(Yc))

  # fixed.x?
  if (length(x.idx) > 0L) {
    dmu[x.idx] <- 0
  }

  dmu
}

# 2b: derivative logl with respect to Sigma (full matrix, ignoring symmetry)
lav_mvnorm_dlogl_dSigma <- function(Y = NULL,
                                    wt = NULL,
                                    Mu = NULL,
                                    Sigma = NULL,
                                    x.idx = integer(0L),
                                    Sinv.method = "eigen",
                                    Sigma.inv = NULL) {
  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }

  Mu <- as.numeric(Mu)

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # W.tilde
  if (!is.null(wt)) {
    out <- stats::cov.wt(Y, wt = wt, method = "ML")
    SY <- out$cov
    MY <- out$center
    W.tilde <- SY + tcrossprod(MY - Mu)
  } else {
    # substract 'Mu' from Y
    # Yc <- t( t(Y) - Mu )
    # W.tilde <- crossprod(Yc) / N
    W.tilde <- lav_matrix_cov(Y, Mu = Mu)
  }

  # derivative
  dSigma <- -(N / 2) * (Sigma.inv - (Sigma.inv %*% W.tilde %*% Sigma.inv))

  # fixed.x?
  if (length(x.idx) > 0L) {
    dSigma[x.idx, x.idx] <- 0
  }

  dSigma
}

# 2c: derivative logl with respect to vech(Sigma)
lav_mvnorm_dlogl_dvechSigma <- function(Y = NULL,
                                        wt = NULL,
                                        Mu = NULL,
                                        Sigma = NULL,
                                        x.idx = integer(0L),
                                        Sinv.method = "eigen",
                                        Sigma.inv = NULL) {
  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }

  Mu <- as.numeric(Mu)

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # W.tilde
  if (!is.null(wt)) {
    out <- stats::cov.wt(Y, wt = wt, method = "ML")
    SY <- out$cov
    MY <- out$center
    W.tilde <- SY + tcrossprod(MY - Mu)
  } else {
    W.tilde <- lav_matrix_cov(Y, Mu = Mu)
  }

  # derivative (avoiding kronecker product)
  dSigma <- -(N / 2) * (Sigma.inv - (Sigma.inv %*% W.tilde %*% Sigma.inv))

  # fixed.x?
  if (length(x.idx) > 0L) {
    dSigma[x.idx, x.idx] <- 0
  }

  # vech
  dvechSigma <- as.numeric(lav_matrix_duplication_pre(
      as.matrix(lav_matrix_vec(dSigma))
  ))

  dvechSigma
}

# 2d: : derivative logl with respect to Mu and vech(Sigma)
lav_mvnorm_dlogl_dmu_dvechSigma <- function(Y = NULL,
                                            wt = NULL,
                                            Mu = NULL,
                                            Sigma = NULL,
                                            x.idx = integer(0L),
                                            Sinv.method = "eigen",
                                            Sigma.inv = NULL) {
  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }

  Mu <- as.numeric(Mu)

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # substract Mu
  Yc <- t(t(Y) - Mu)

  # W.tilde
  if (!is.null(wt)) {
    out <- stats::cov.wt(Y, wt = wt, method = "ML")
    SY <- out$cov
    MY <- out$center
    W.tilde <- SY + tcrossprod(MY - Mu)
    dmu <- as.numeric(Sigma.inv %*% colSums(Yc * wt))
  } else {
    W.tilde <- lav_matrix_cov(Y, Mu = Mu)
    dmu <- as.numeric(Sigma.inv %*% colSums(Yc))
  }

  # derivative (avoiding kronecker product)
  dSigma <- -(N / 2) * (Sigma.inv - (Sigma.inv %*% W.tilde %*% Sigma.inv))

  # fixed.x?
  if (length(x.idx) > 0L) {
    dSigma[x.idx, x.idx] <- 0
    dmu[x.idx] <- 0
  }

  # vech
  dvechSigma <- as.numeric(lav_matrix_duplication_pre(
    as.matrix(lav_matrix_vec(dSigma))
  ))

  c(dmu, dvechSigma)
}

# 3. Casewise scores

# 3a: casewise scores with respect to mu
lav_mvnorm_scores_mu <- function(Y = NULL,
                                 wt = NULL,
                                 Mu = NULL,
                                 x.idx = integer(0L),
                                 Sigma = NULL,
                                 Sinv.method = "eigen",
                                 Sigma.inv = NULL) {
  Mu <- as.numeric(Mu)

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # substract Mu
  Yc <- t(t(Y) - Mu)

  # postmultiply with Sigma.inv
  SC <- Yc %*% Sigma.inv

  # weights
  if (!is.null(wt)) {
    SC <- SC * wt
  }

  # fixed.x?
  if (length(x.idx) > 0L) {
    SC[, x.idx] <- 0
  }

  SC
}

# 3b: casewise scores with respect to vech(Sigma)
lav_mvnorm_scores_vech_sigma <- function(Y = NULL,
                                         wt = NULL,
                                         Mu = NULL,
                                         Sigma = NULL,
                                         x.idx = integer(0L),
                                         Sinv.method = "eigen",
                                         Sigma.inv = NULL) {
  P <- NCOL(Y)
  Mu <- as.numeric(Mu)

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # vech(Sigma.inv)
  isigma <- lav_matrix_vech(Sigma.inv)

  # substract Mu
  Yc <- t(t(Y) - Mu)

  # postmultiply with Sigma.inv
  Yc <- Yc %*% Sigma.inv

  # tcrossprod
  idx1 <- lav_matrix_vech_col_idx(P)
  idx2 <- lav_matrix_vech_row_idx(P)
  Z <- Yc[, idx1] * Yc[, idx2]

  # substract isigma from each row
  SC <- t(t(Z) - isigma)

  # adjust for vech
  SC[, lav_matrix_diagh_idx(P)] <- SC[, lav_matrix_diagh_idx(P)] / 2

  # fixed.x?
  if (length(x.idx) > 0L) {
    SC[, lav_matrix_vech_which_idx(n = P, idx = x.idx)] <- 0
  }

  # weights
  if (!is.null(wt)) {
    SC <- SC * wt
  }

  SC
}

# 3c: casewise scores with respect to mu + vech(Sigma)
lav_mvnorm_scores_mu_vech_sigma <- function(Y = NULL,
                                            wt = NULL,
                                            Mu = NULL,
                                            Sigma = NULL,
                                            x.idx = integer(0L),
                                            Sinv.method = "eigen",
                                            Sigma.inv = NULL) {
  P <- NCOL(Y)
  Mu <- as.numeric(Mu)

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # vech(Sigma.inv)
  isigma <- lav_matrix_vech(Sigma.inv)

  # substract Mu
  Yc <- t(t(Y) - Mu)

  # postmultiply with Sigma.inv
  Yc <- Yc %*% Sigma.inv

  # tcrossprod
  idx1 <- lav_matrix_vech_col_idx(P)
  idx2 <- lav_matrix_vech_row_idx(P)
  Z <- Yc[, idx1] * Yc[, idx2]

  # substract isigma from each row
  SC <- t(t(Z) - isigma)

  # adjust for lav_matrix_duplication_pre (not vech!)
  SC[, lav_matrix_diagh_idx(P)] <- SC[, lav_matrix_diagh_idx(P)] / 2

  # fixed.x?
  if (length(x.idx) > 0L) {
    Yc[, x.idx] <- 0
    SC[, lav_matrix_vech_which_idx(n = P, idx = x.idx)] <- 0
  }

  out <- cbind(Yc, SC)

  # weights
  if (!is.null(wt)) {
    out <- out * wt
  }

  out
}


# 4. hessian of logl

# 4a: hessian logl Mu and vech(Sigma) from raw data
lav_mvnorm_logl_hessian_data <- function(Y = NULL,
                                         wt = NULL,
                                         Mu = NULL,
                                         Sigma = NULL,
                                         x.idx = integer(0L),
                                         Sinv.method = "eigen",
                                         Sigma.inv = NULL,
                                         meanstructure = TRUE) {
  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }

  # observed information
  observed <- lav_mvnorm_information_observed_data(
    Y = Y, wt = wt, Mu = Mu,
    Sigma = Sigma, x.idx = x.idx,
    Sinv.method = Sinv.method, Sigma.inv = Sigma.inv,
    meanstructure = meanstructure
  )

  -N * observed
}

# 4b: hessian Mu and vech(Sigma) from samplestats
lav_mvnorm_logl_hessian_samplestats <-
  function(sample.mean = NULL,
           sample.cov = NULL,
           sample.nobs = NULL,
           Mu = NULL,
           Sigma = NULL,
           x.idx = integer(0L),
           Sinv.method = "eigen",
           Sigma.inv = NULL,
           meanstructure = TRUE) {
    N <- sample.nobs

    # observed information
    observed <- lav_mvnorm_information_observed_samplestats(
      sample.mean = sample.mean, sample.cov = sample.cov,
      Mu = Mu, Sigma = Sigma,
      x.idx = x.idx, Sinv.method = Sinv.method, Sigma.inv = Sigma.inv,
      meanstructure = meanstructure
    )

    -N * observed
  }

# 5) Information h0

# 5a: unit expected information h0 Mu and vech(Sigma)
lav_mvnorm_information_expected <- function(Y = NULL, # unused!
                                            wt = NULL, # unused!
                                            Mu = NULL, # unused!
                                            Sigma = NULL,
                                            x.idx = integer(0L),
                                            Sinv.method = "eigen",
                                            Sigma.inv = NULL,
                                            meanstructure = TRUE,
											correlation = FALSE) {
  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  # if (lav_use_lavaanC()) {
  #   if (correlation) {
  #     I22 <- lavaanC::m_kronecker_dup_cor_pre_post(Sigma.inv,
  #                                                  multiplicator = 0.5)
  #   } else {
  #     I22 <- lavaanC::m_kronecker_dup_pre_post(Sigma.inv, multiplicator = 0.5)
  #   }
  # } else {
    if (correlation) {
      I22 <- 0.5 * lav_matrix_duplication_cor_pre_post(Sigma.inv %x% Sigma.inv)
    } else {
      I22 <- 0.5 * lav_matrix_duplication_pre_post(Sigma.inv %x% Sigma.inv)
    }
  # }

  # fixed.x?
  if (length(x.idx) > 0L) {
    pstar.x <- lav_matrix_vech_which_idx(
      n = NCOL(Sigma.inv), idx = x.idx
    )
    I22[pstar.x, ] <- 0
    I22[, pstar.x] <- 0
  }

  if (meanstructure) {
    I11 <- Sigma.inv
    # fixed.x?
    if (length(x.idx) > 0L) {
      I11[x.idx, ] <- 0
      I11[, x.idx] <- 0
    }
    out <- lav_matrix_bdiag(I11, I22)
  } else {
    out <- I22
  }

  out
}

# 5b: unit observed information h0
lav_mvnorm_information_observed_data <- function(Y = NULL,
                                                 wt = NULL,
                                                 Mu = NULL,
                                                 Sigma = NULL,
                                                 x.idx = integer(0L),
                                                 Sinv.method = "eigen",
                                                 Sigma.inv = NULL,
                                                 meanstructure = TRUE) {
  if (!is.null(wt)) {
    N <- sum(wt)
    out <- stats::cov.wt(Y, wt = wt, method = "ML")
    sample.cov <- out$cov
    sample.mean <- out$center
  } else {
    N <- NROW(Y)
    # sample statistics
    sample.mean <- colMeans(Y)
    sample.cov <- lav_matrix_cov(Y)
  }

  lav_mvnorm_information_observed_samplestats(
    sample.mean = sample.mean,
    sample.cov = sample.cov, Mu = Mu, Sigma = Sigma,
    x.idx = x.idx, Sinv.method = Sinv.method, Sigma.inv = Sigma.inv,
    meanstructure = meanstructure
  )
}

# 5b-bis: observed information h0 from sample statistics
lav_mvnorm_information_observed_samplestats <- function(
    sample.mean = NULL,
    sample.cov = NULL,
    Mu = NULL,
    Sigma = NULL,
    x.idx = integer(0L),
    Sinv.method = "eigen",
    Sigma.inv = NULL,
    meanstructure = TRUE) {

  sample.mean <- as.numeric(sample.mean)
  Mu <- as.numeric(Mu)

  if (is.null(Sigma.inv)) {
    # invert Sigma
    Sigma.inv <- lav_matrix_symmetric_inverse(
      S = Sigma, logdet = FALSE,
      Sinv.method = Sinv.method
    )
  }

  W.tilde <- sample.cov + tcrossprod(sample.mean - Mu)

  if (meanstructure) {
    I11 <- Sigma.inv
    I21 <- lav_matrix_duplication_pre((Sigma.inv %*%
      (sample.mean - Mu)) %x% Sigma.inv)
    I12 <- t(I21)
  }

  AAA <- Sigma.inv %*% (2 * W.tilde - Sigma) %*% Sigma.inv
  # if (lav_use_lavaanC()) {
  #   I22 <- lavaanC::m_kronecker_dup_pre_post(Sigma.inv, AAA, 0.5)
  # } else {
    I22 <- (1 / 2) * lav_matrix_duplication_pre_post(Sigma.inv %x% AAA)
  # }

  if (meanstructure) {
    out <- rbind(
      cbind(I11, I12),
      cbind(I21, I22)
    )
  } else {
    out <- I22
  }

  # fixed.x?
  if (length(x.idx) > 0L) {
    not.x <- lav_matrix_vech_which_idx(
      n = NCOL(Sigma.inv), idx = x.idx,
      add.idx.at.start = meanstructure
    )
    out[, not.x] <- 0
    out[not.x, ] <- 0
  }

  out
}

# 5c: unit first-order information h0
lav_mvnorm_information_firstorder <- function(Y = NULL,
                                              wt = NULL,
                                              cluster.idx = NULL,
                                              Mu = NULL,
                                              Sigma = NULL,
                                              x.idx = integer(0L),
                                              Sinv.method = "eigen",
                                              Sigma.inv = NULL,
                                              meanstructure = TRUE) {
  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }

  if (meanstructure) {
    SC <- lav_mvnorm_scores_mu_vech_sigma(
      Y = Y, wt = wt,
      Mu = Mu, Sigma = Sigma, x.idx = x.idx,
      Sinv.method = Sinv.method, Sigma.inv = Sigma.inv
    )
  } else {
    # the caller should use Mu = sample.mean
    SC <- lav_mvnorm_scores_vech_sigma(
      Y = Y, wt = wt,
      Mu = Mu, Sigma = Sigma,
      Sinv.method = Sinv.method, Sigma.inv = Sigma.inv
    )
  }

  # handle clustering
  if (!is.null(cluster.idx)) {
    # take the sum within each cluster
    SC <- rowsum(SC, group = cluster.idx, reorder = FALSE, na.rm = TRUE)

    # lower bias if number of clusters is not very high
    # FIXME: reference?
    nC <- nrow(SC)
    correction.factor <- nC / (nC - 1)
    SC <- SC * sqrt(correction.factor)
  }

  # unit information
  out <- crossprod(SC) / N

  out
}


# 6: inverted information h0

# 6a: inverted unit expected information h0 Mu and vech(Sigma)
#
#     Note: this is the same as lav_samplestats_Gamma_NT()
#           but where COV=Sigma and MEAN=Mu
#
lav_mvnorm_inverted_information_expected <- function(Y = NULL, # unused!
                                                     wt = NULL, # unused!
                                                     Mu = NULL, # unused!
                                                     Sigma = NULL,
                                                     x.idx = integer(0L),
                                                     meanstructure = TRUE) {
  if (length(x.idx) > 0L) {
    # cov(Y|X) = A - B C^{-1} B'
    # where A = cov(Y), B = cov(Y,X), C = cov(X)
    A <- Sigma[-x.idx, -x.idx, drop = FALSE]
    B <- Sigma[-x.idx,  x.idx, drop = FALSE]
    C <- Sigma[ x.idx,  x.idx, drop = FALSE]
    YbarX <- A - B %*% solve(C, t(B))

    # reinsert YbarX in Y+X (residual) covariance matrix
    YbarX.aug <- matrix(0, nrow = NROW(Sigma), ncol = NCOL(Sigma))
    YbarX.aug[-x.idx, -x.idx] <- YbarX

    # take difference
    R <- Sigma - YbarX.aug

    # if (lav_use_lavaanC()) {
    #   SS <- lavaanC::m_kronecker_dup_ginv_pre_post(Sigma, multiplicator = 2.0)
    #   RR <- lavaanC::m_kronecker_dup_ginv_pre_post(R, multiplicator = 2.0)
    # } else {
      SS <- 2 * lav_matrix_duplication_ginv_pre_post(Sigma %x% Sigma)
      RR <- 2 * lav_matrix_duplication_ginv_pre_post(R %x% R)
    # }
    I22 <- SS - RR

    if (meanstructure) {
      I11 <- YbarX.aug
      out <- lav_matrix_bdiag(I11, I22)
    } else {
      out <- I22
    }
  } else {
    # if (lav_use_lavaanC()) {
    #   I22 <- lavaanC::m_kronecker_dup_ginv_pre_post(Sigma, multiplicator = 2.0)
    # } else {
      I22 <- 2 * lav_matrix_duplication_ginv_pre_post(Sigma %x% Sigma)
    # }
    if (meanstructure) {
      I11 <- Sigma
      out <- lav_matrix_bdiag(I11, I22)
    } else {
      out <- I22
    }
  }

  out
}

# 6b:  inverted unit observed information h0

# one could use the inverse of a partitioned matrix, but that does not
# seem to help much... unless we can find an expression for solve(I22)

# 6c: inverted unit first-order information h0
# /


# 7) ACOV h0 mu + vech(Sigma)
# not implemented, as too trivial

#    7a: 1/N * inverted expected    information

#    7b: 1/N * inverted observed    information

#    7c: 1/N * inverted first-order information

#    7d: sandwich acov

# the weighted bivariate linear regression model
# YR 14 March 2020 ((replacing the old lav_pearson.R + lav_binorm.R routines)
#
# - bivariate standard normal
# - pearson correlation
# - bivariate linear regression
# - using sampling weights wt


# density of a bivariate __standard__ normal
lav_dbinorm <- lav_dbinorm <- function(u, v, rho, force.zero = FALSE) {
  # dirty hack to handle extreme large values for rho
  # note that u, v, and rho are vectorized!
  RHO.limit <- 0.9999
  abs.rho <- abs(rho)
  idx <- which(abs.rho > RHO.limit)
  if (length(idx) > 0L) {
    rho[idx] <- sign(rho[idx]) * RHO.limit
  }

  R <- 1 - rho * rho
  out <- 1 / (2 * pi * sqrt(R)) * exp(-0.5 * (u * u - 2 * rho * u * v + v * v) / R)

  # if abs(u) or abs(v) are very large (say, >10), set result equal
  # to exactly zero
  idx <- which(abs(u) > 10 | abs(v) > 10)
  if (length(idx) > 0L && force.zero) {
    out[idx] <- 0
  }

  out
}

# partial derivative - rho
lav_dbinorm_drho <- function(u, v, rho) {
  R <- 1 - rho * rho
  lav_dbinorm(u, v, rho) * (u * v * R - rho * (u * u - 2 * rho * u * v + v * v) + rho * R) / (R * R)
}

# partial derivative - u
lav_dbinorm_du <- function(u, v, rho) {
  R <- 1 - rho * rho
  -lav_dbinorm(u, v, rho) * (u - rho * v) / R
}

# partial derivative - v
lav_dbinorm_dv <- function(u, v, rho) {
  R <- 1 - rho * rho
  -lav_dbinorm(u, v, rho) * (v - rho * u) / R
}


# CDF of bivariate standard normal
# function pbinorm(upper.x, upper.y, rho)

# partial derivative pbinorm - upper.x
lav_pbinorm_dupperx <- function(upper.x, upper.y, rho = 0.0) {
  R <- 1 - rho * rho
  dnorm(upper.x) * pnorm((upper.y - rho * upper.x) / sqrt(R))
}

lav_pbinorm_duppery <- function(upper.x, upper.y, rho = 0.0) {
  R <- 1 - rho * rho
  dnorm(upper.y) * pnorm((upper.x - rho * upper.y) / sqrt(R))
}

lav_pbinorm_drho <- function(upper.x, upper.y, rho = 0.0) {
  lav_dbinorm(upper.x, upper.y, rho)
}


# switch between pbivnorm, mnormt, ...
pbinorm <- function(upper.x = NULL, upper.y = NULL, rho = 0.0,
                    lower.x = -Inf, lower.y = -Inf, check = FALSE) {
  pbinorm2(
    upper.x = upper.x, upper.y = upper.y, rho = rho,
    lower.x = lower.x, lower.y = lower.y, check = check
  )
}

# using vectorized version (a la pbivnorm)
pbinorm2 <- function(upper.x = NULL, upper.y = NULL, rho = 0.0,
                     lower.x = -Inf, lower.y = -Inf, check = FALSE) {
  N <- length(upper.x)
  stopifnot(length(upper.y) == N)
  if (N > 1L) {
    if (length(rho) == 1L) {
      rho <- rep(rho, N)
    }
    if (length(lower.x) == 1L) {
      lower.x <- rep(lower.x, N)
    }
    if (length(lower.y) == 1L) {
      lower.y <- rep(lower.y, N)
    }
  }

  upper.only <- all(lower.x == -Inf & lower.y == -Inf)
  if (upper.only) {
    upper.x[upper.x == +Inf] <- exp(10) # better pnorm?
    upper.y[upper.y == +Inf] <- exp(10)
    upper.x[upper.x == -Inf] <- -exp(10)
    upper.y[upper.y == -Inf] <- -exp(10)
    res <- pbivnorm(upper.x, upper.y, rho = rho)
  } else {
    # pbivnorm does not handle -Inf well...
    lower.x[lower.x == -Inf] <- -exp(10)
    lower.y[lower.y == -Inf] <- -exp(10)
    res <- pbivnorm(upper.x, upper.y, rho = rho) -
      pbivnorm(lower.x, upper.y, rho = rho) -
      pbivnorm(upper.x, lower.y, rho = rho) +
      pbivnorm(lower.x, lower.y, rho = rho)
  }

  res
}



# pearson correlation
# if no missing, solution is just cor(Y1,Y2) or cor(e1,e2)
# but if missing, two-step solution is NOT the same as cor(Y1,Y2) or cor(e1,e2)
lav_bvreg_cor_twostep_fit <- function(Y1, Y2, eXo = NULL, wt = NULL,
                                      fit.y1 = NULL, fit.y2 = NULL,
                                      Y1.name = NULL, Y2.name = NULL,
                                      optim.method = "nlminb1",
                                      # optim.method = "none",
                                      optim.scale = 1,
                                      init.theta = NULL,
                                      control = list()) {
  if (is.null(fit.y1)) {
    fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt)
  }
  if (is.null(fit.y2)) {
    fit.y2 <- lav_uvreg_fit(y = Y2, X = eXo, wt = wt)
  }

  # create cache environment
  cache <- lav_bvreg_init_cache(fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt)

  # the complete case is trivial
  if (!anyNA(fit.y1$y) && !anyNA(fit.y2$y)) {
    return(cache$theta[1L])
  }

  # optim.method
  minObjective <- lav_bvreg_min_objective
  minGradient <- lav_bvreg_min_gradient
  minHessian <- lav_bvreg_min_hessian
  if (optim.method == "nlminb" || optim.method == "nlminb2") {
    # nothing to do
  } else if (optim.method == "nlminb0") {
    minGradient <- minHessian <- NULL
  } else if (optim.method == "nlminb1") {
    minHessian <- NULL
  } else if (optim.method == "none") {
    return(cache$theta[1L])
  }

  # optimize
  if (is.null(control$trace)) {
    control$trace <- ifelse(lav_verbose(), 1, 0)
  }

  # init theta?
  if (!is.null(init.theta)) {
    start.x <- init.theta
  } else {
    start.x <- cache$theta
  }

  # try 1
  optim <- nlminb(
    start = start.x, objective = minObjective,
    gradient = minGradient, hessian = minHessian,
    control = control,
    scale = optim.scale, lower = -0.999, upper = +0.999,
    cache = cache
  )

  # try 2 (scale = 10)
  if (optim$convergence != 0L) {
    optim <- nlminb(
      start = start.x, objective = minObjective,
      gradient = minGradient, hessian = minHessian,
      control = control,
      scale = 10, lower = -0.999, upper = +0.999,
      cache = cache
    )
  }

  # try 3 (start = 0, step.min = 0.1)
  if (optim$convergence != 0L) {
    control$step.min <- 0.1
    minGradient <- lav_bvreg_min_gradient
    # try again, with different starting value
    optim <- nlminb(
      start = 0, objective = minObjective,
      gradient = minGradient, hessian = NULL,
      control = control,
      scale = optim.scale, lower = -0.999, upper = +0.999,
      cache = cache
    )
  }

  # check convergence
  if (optim$convergence != 0L) {
    if (!is.null(Y1.name) && !is.null(Y2.name)) {
      lav_msg_warn(gettextf(
        "estimation pearson correlation did not converge for variables %1$s
        and %2$s.", Y1.name, Y2.name))
    } else {
      lav_msg_warn(gettext(
        "estimation pearson correlation(s) did not always converge"))
    }

    # use init (as we always did in < 0.6-6; this is also what Mplus does)
    rho <- start.x
  } else {
    # store result
    rho <- optim$par
  }

  rho
}

# Y1 = linear
# Y2 = linear
lav_bvreg_init_cache <- function(fit.y1 = NULL,
                                 fit.y2 = NULL,
                                 wt = NULL,
                                 scores = FALSE,
                                 parent = parent.frame()) {
  # data
  Y1 <- fit.y1$y
  Y2 <- fit.y2$y
  eXo <- fit.y1$X

  # Y1
  Y1c <- Y1 - fit.y1$yhat
  evar.y1 <- fit.y1$theta[fit.y1$var.idx]
  sd.y1 <- sqrt(evar.y1)
  eta.y1 <- fit.y1$yhat

  # Y2
  Y2c <- Y2 - fit.y2$yhat
  evar.y2 <- fit.y2$theta[fit.y1$var.idx]
  sd.y2 <- sqrt(evar.y2)
  eta.y2 <- fit.y2$yhat


  # exo?
  if (is.null(eXo)) {
    nexo <- 0L
  } else {
    nexo <- ncol(eXo)
  }

  # nobs
  if (is.null(wt)) {
    N <- length(Y1)
  } else {
    N <- sum(wt)
  }

  # starting value
  if (fit.y1$nexo > 0L) {
    E1 <- Y1 - fit.y1$yhat
    E2 <- Y2 - fit.y2$yhat
    if (is.null(wt)) {
      rho.init <- cor(E1, E2, use = "pairwise.complete.obs")
    } else {
      tmp <- na.omit(cbind(E1, E2, wt))
      rho.init <- cov.wt(tmp[, 1:2], wt = tmp[, 3], cor = TRUE)$cor[2, 1]
    }
  } else {
    if (is.null(wt)) {
      rho.init <- cor(Y1, Y2, use = "pairwise.complete.obs")
    } else {
      tmp <- na.omit(cbind(Y1, Y2, wt))
      rho.init <- cov.wt(tmp[, 1:2], wt = tmp[, 3], cor = TRUE)$cor[2, 1]
    }
  }

  # sanity check
  if (is.na(rho.init) || abs(rho.init) >= 1.0) {
    rho.init <- 0.0
  }

  # parameter vector
  theta <- rho.init # only

  # different cache if scores or not
  if (scores) {
    out <- list2env(
      list(
        nexo = nexo, theta = theta, N = N,
        Y1c = Y1c, Y2c = Y2c, eXo = eXo,
        evar.y1 = evar.y1, sd.y1 = sd.y1, eta.y1 = eta.y1,
        evar.y2 = evar.y2, sd.y2 = sd.y2, eta.y2 = eta.y2
      ),
      parent = parent
    )
  } else {
    out <- list2env(
      list(
        nexo = nexo, theta = theta, N = N,
        Y1c = Y1c, Y2c = Y2c,
        evar.y1 = evar.y1, sd.y1 = sd.y1, eta.y1 = eta.y1,
        evar.y2 = evar.y2, sd.y2 = sd.y2, eta.y2 = eta.y2
      ),
      parent = parent
    )
  }

  out
}


# casewise likelihoods, unweighted!
lav_bvreg_lik_cache <- function(cache = NULL) {
  with(cache, {
    rho <- theta[1L]

    cov.y12 <- rho * sqrt(evar.y1) * sqrt(evar.y2)
    sigma <- matrix(c(evar.y1, cov.y12, cov.y12, evar.y2), 2L, 2L)
    lik <- exp(lav_mvnorm_loglik_data(
      Y = cbind(Y1c, Y2c), wt = NULL,
      Mu = c(0, 0), Sigma = sigma,
      casewise = TRUE
    ))
    # catch very small values
    lik.toosmall.idx <- which(lik < sqrt(.Machine$double.eps))
    lik[lik.toosmall.idx] <- as.numeric(NA)

    return(lik)
  })
}

lav_bvreg_logl_cache <- function(cache = NULL) {
  with(cache, {
    lik <- lav_bvreg_lik_cache(cache) # unweighted!

    if (!is.null(wt)) {
      logl <- sum(wt * log(lik), na.rm = TRUE)
    } else {
      logl <- sum(log(lik), na.rm = TRUE)
    }

    return(logl)
  })
}

lav_bvreg_gradient_cache <- function(cache = NULL) {
  with(cache, {
    rho <- theta[1L]
    R <- (1 - rho * rho)

    sd.y1.y2 <- sd.y1 * sd.y2
    t1 <- (Y1c * Y2c) / sd.y1.y2
    t2 <- (Y1c * Y1c) / evar.y1 - (2 * rho * t1) + (Y2c * Y2c) / evar.y2
    dx <- (rho + t1 - t2 * rho / R) / R

    # to be consistent with (log)lik_cache
    if (length(lik.toosmall.idx) > 0L) {
      dx[lik.toosmall.idx] <- as.numeric(NA)
    }

    if (is.null(wt)) {
      dx.rho <- sum(dx, na.rm = TRUE)
    } else {
      dx.rho <- sum(wt * dx, na.rm = TRUE)
    }

    return(dx.rho)
  })
}

lav_bvreg_hessian_cache <- function(cache = NULL) {
  with(cache, {
    rho <- theta[1L]

    rho2 <- rho * rho
    R2 <- R * R
    R3 <- R * R * R

    h <- 1 / R - (2 * rho2 * t2) / R3 + 2 * rho2 * (1 - t2 / R) / R2 + 4 * rho * t1 / R2 - t2 / R2

    # to be consistent with (log)lik_cache
    if (length(lik.toosmall.idx) > 0L) {
      h[lik.toosmall.idx] <- as.numeric(NA)
    }

    if (is.null(wt)) {
      H <- sum(h, na.rm = TRUE)
    } else {
      H <- sum(wt * h, na.rm = TRUE)
    }
    dim(H) <- c(1L, 1L) # for nlminb

    return(H)
  })
}

# compute total (log)likelihood, for specific 'x' (nlminb)
lav_bvreg_min_objective <- function(x, cache = NULL) {
  cache$theta <- x
  -1 * lav_bvreg_logl_cache(cache = cache) / cache$N
}

# compute gradient, for specific 'x' (nlminb)
lav_bvreg_min_gradient <- function(x, cache = NULL) {
  # check if x has changed
  if (!all(x == cache$theta)) {
    cache$theta <- x
    tmp <- lav_bvreg_logl_cache(cache = cache)
  }
  -1 * lav_bvreg_gradient_cache(cache = cache) / cache$N
}

# compute hessian, for specific 'x' (nlminb)
lav_bvreg_min_hessian <- function(x, cache = NULL) {
  # check if x has changed
  if (!all(x == cache$theta)) {
    tmp <- lav_bvreg_logl_cache(cache = cache)
    tmp <- lav_bvreg_gradient_cache(cache = cache)
  }
  -1 * lav_bvreg_hessian_cache(cache = cache) / cache$N
}

# casewise scores - cache
# FIXME: should we also set 'lik.toosmall.idx' cases to NA?
lav_bvreg_cor_scores_cache <- function(cache = NULL) {
  with(cache, {
    rho <- theta[1L]
    R <- (1 - rho * rho)

    # mu.y1
    dx.mu.y1 <- (2 * Y1c / evar.y1 - 2 * rho * Y2c / (sd.y1 * sd.y2)) / (2 * R)
    if (!is.null(wt)) {
      dx.mu.y1 <- wt * dx.mu.y1
    }

    # mu.y2
    dx.mu.y2 <- -(2 * rho * Y1c / (sd.y1 * sd.y2) - 2 * Y2c / evar.y2) / (2 * R)
    if (!is.null(wt)) {
      dx.mu.y2 <- wt * dx.mu.y2
    }

    # evar.y1
    dx.var.y1 <- -(0.5 / evar.y1 - ((Y1c * Y1c) / (evar.y1 * evar.y1) -
      rho * Y1c * Y2c / (evar.y1 * sd.y1 * sd.y2)) / (2 * R))
    if (!is.null(wt)) {
      dx.var.y1 <- wt * dx.var.y1
    }

    # var.y2
    dx.var.y2 <- -(0.5 / evar.y2 + (rho * Y1c * Y2c / (evar.y2 * sd.y1 * sd.y2) -
      (Y2c * Y2c) / (evar.y2 * evar.y2)) / (2 * R))
    if (!is.null(wt)) {
      dx.var.y2 <- wt * dx.var.y2
    }

    # sl.y1
    dx.sl.y1 <- NULL
    if (nexo > 0L) {
      dx.sl.y1 <- dx.mu.y1 * eXo # weights already included in dx.mu.y1
    }

    # sl.y2
    dx.sl.y2 <- NULL
    if (nexo > 0L) {
      dx.sl.y2 <- dx.mu.y2 * eXo # weights already included in dx.mu.y2
    }

    # rho
    z <- (Y1c * Y1c) / evar.y1 - 2 * rho * Y1c * Y2c / (sd.y1 * sd.y2) + (Y2c * Y2c) / evar.y2
    dx.rho <- rho / R + (Y1c * Y2c / (sd.y1 * sd.y2 * R) - z * rho / (R * R))
    if (!is.null(wt)) {
      dx.rho <- wt * dx.rho
    }

    out <- list(
      dx.mu.y1 = dx.mu.y1, dx.var.y1 = dx.var.y1,
      dx.mu.y2 = dx.mu.y2, dx.var.y2 = dx.var.y2,
      dx.sl.y1 = dx.sl.y1, dx.sl.y2 = dx.sl.y2,
      dx.rho = dx.rho
    )
    return(out)
  })
}

# casewise scores
#
# Y1 = linear
# Y2 = linear
lav_bvreg_cor_scores <- function(Y1, Y2, eXo = NULL, wt = NULL,
                                 rho = NULL,
                                 fit.y1 = NULL, fit.y2 = NULL,
                                 evar.y1 = NULL, beta.y1 = NULL,
                                 evar.y2 = NULL, beta.y2 = NULL) {
  if (is.null(fit.y1)) {
    fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt)
  }
  if (is.null(fit.y2)) {
    fit.y2 <- lav_uvreg_fit(y = Y2, X = eXo, wt = wt)
  }

  # user specified parameters
  if (!is.null(evar.y1) || !is.null(beta.y1)) {
    fit.y1 <- lav_uvreg_update_fit(
      fit.y = fit.y1,
      evar.new = evar.y1, beta.new = beta.y1
    )
  }
  if (!is.null(evar.y2) || !is.null(beta.y2)) {
    fit.y2 <- lav_uvreg_update_fit(
      fit.y = fit.y2,
      evar.new = evar.y2, beta.new = beta.y2
    )
  }

  # create cache environment
  cache <- lav_bvreg_init_cache(
    fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt,
    scores = TRUE
  )
  cache$theta <- rho

  SC <- lav_bvreg_cor_scores_cache(cache = cache)

  SC
}

# logl - no cache
lav_bvreg_logl <- function(Y1, Y2, eXo = NULL, wt = NULL,
                           rho = NULL,
                           fit.y1 = NULL, fit.y2 = NULL,
                           evar.y1 = NULL, beta.y1 = NULL,
                           evar.y2 = NULL, beta.y2 = NULL) {
  if (is.null(fit.y1)) {
    fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt)
  }
  if (is.null(fit.y2)) {
    fit.y2 <- lav_uvreg_fit(y = Y2, X = eXo, wt = wt)
  }

  # user specified parameters
  if (!is.null(evar.y1) || !is.null(beta.y1)) {
    fit.y1 <- lav_uvreg_update_fit(
      fit.y = fit.y1,
      evar.new = evar.y1, beta.new = beta.y1
    )
  }
  if (!is.null(evar.y2) || !is.null(beta.y2)) {
    fit.y2 <- lav_uvreg_update_fit(
      fit.y = fit.y2,
      evar.new = evar.y2, beta.new = beta.y2
    )
  }

  # create cache environment
  cache <- lav_bvreg_init_cache(
    fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt,
    scores = TRUE
  )
  cache$theta <- rho

  lav_bvreg_logl_cache(cache = cache)
}

# lik - no cache
lav_bvreg_lik <- function(Y1, Y2, eXo = NULL, wt = NULL,
                          rho = NULL,
                          fit.y1 = NULL, fit.y2 = NULL,
                          evar.y1 = NULL, beta.y1 = NULL,
                          evar.y2 = NULL, beta.y2 = NULL,
                          .log = FALSE) {
  if (is.null(fit.y1)) {
    fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt)
  }
  if (is.null(fit.y2)) {
    fit.y2 <- lav_uvreg_fit(y = Y2, X = eXo, wt = wt)
  }

  # user specified parameters
  if (!is.null(evar.y1) || !is.null(beta.y1)) {
    fit.y1 <- lav_uvreg_update_fit(
      fit.y = fit.y1,
      evar.new = evar.y1, beta.new = beta.y1
    )
  }
  if (!is.null(evar.y2) || !is.null(beta.y2)) {
    fit.y2 <- lav_uvreg_update_fit(
      fit.y = fit.y2,
      evar.new = evar.y2, beta.new = beta.y2
    )
  }

  # create cache environment
  cache <- lav_bvreg_init_cache(
    fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt,
    scores = TRUE
  )
  cache$theta <- rho

  lik <- lav_bvreg_lik_cache(cache = cache)
  if (.log) {
    lik <- log(lik)
  }

  if (!is.null(wt)) {
    if (.log) {
      lik <- wt * lik
    } else {
      tmp <- wt * log(lik)
      lik <- exp(tmp)
    }
  }

  lik
}

# the entries of the lavaan and lavaanList objects have changed over time
# this function will check if the lavaan/lavaanList object is up to date, and
# adapt, if not.
#
# this may be useful if an older (say 0.5) lavaan object was saved, and
# passed to a function like lavPredict() in, say, lavaan 0.6-21.

# notes:
# - pre<0.5 lavaan objects are no longer supported
# - @Fit slot is ignored (as not used anymore)

# YR 16 Oct 2025 + LDW 22 Oct 2025

lav_object_check_version <- function(object = NULL) {

  is.lavaan.object <- inherits(object, "lavaan")
  if (!is.lavaan.object) {
    # check if lavaanList object, if not return input object
    if (!inherits(object, "lavaanList")) return(object)
  }

  # flag: check or not?
  check_not_needed_flag <- TRUE

  # do we have a version slot?
  if (.hasSlot(object, "version")) {
    has_version_flag <- TRUE
    lavobject_version <- object@version[1] # lavaan.mi has two
    lavaanpkg_version <- read.dcf(
      file = system.file("DESCRIPTION", package = "lavaan"),
      fields = "Version"
    )[1]
    if (lavobject_version != lavaanpkg_version) {
      check_not_needed_flag <- FALSE
    }
  } else {
    # <0.6
    has_version_flag <- FALSE
    check_not_needed_flag <- FALSE
  }

  # check needed?
  if (check_not_needed_flag) {
    return(object)
  }

  # ok, we have potentially an older (saved) lavaan or lavaanList object
  # check needed slots, and if missing, add them
  suppressWarnings(lavobject <- object)
  ngroups <- lav_partable_ngroups(lavobject@ParTable)
  nblocks <- lav_partable_nblocks(lavobject@ParTable)
  nlevels <- lav_partable_nlevels(lavobject@ParTable)

  if (!has_version_flag) { # pre 0.6 object!
    # 0.5-10 (25 Oct 2012)
    if (!.hasSlot(lavobject@Data, "group")) {
      lavobject@Data@group <- character(0L)
    }

    # 0.5-11 (19 dec 2012)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@SampleStats, "bifreq")) {
        lavobject@SampleStats@bifreq <- vector("list", length = ngroups)
      }
      if (!.hasSlot(lavobject, "Cache")) {
        lavobject@Cache <- list()
      }
    }

    # 0.5-12 (8 March 2013)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@SampleStats, "ridge")) {
        lavobject@SampleStats@ridge <- 0
      }
    }

    # 0.5-14 (21 July 2013)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@Model, "ov.x.dummy.ov.idx")) {
        lavobject@Model@ov.x.dummy.ov.idx <- vector("list", length = nblocks)
        lavobject@Model@ov.x.dummy.lv.idx <- vector("list", length = nblocks)
        lavobject@Model@ov.y.dummy.ov.idx <- vector("list", length = nblocks)
        lavobject@Model@ov.y.dummy.lv.idx <- vector("list", length = nblocks)
      }
      if (!.hasSlot(lavobject@SampleStats, "mean.x")) {
        lavobject@SampleStats@mean.x <- vector("list", length = ngroups)
        for (g in seq_len(ngroups)) {
          if (!is.null(lavobject@SampleStats@x.idx[[g]])) {
            lavobject@SampleStats@mean.x[[g]] <-
              lavobject@SampleStats@mean[[g]][lavobject@SampleStats@x.idx[[g]]]
          }
        }
      }
      if (!.hasSlot(lavobject, "pta")) {
        lavobject@pta <- list()
      }
    }

    # 0.5-15 (15 Nov 2013)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@Data, "Rp")) {
        lavobject@Data@Rp <- vector("list", length = ngroups)
      }
    }

    # 0.5-16 (7 March 2014)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@SampleStats, "group.w")) {
        lavobject@SampleStats@group.w <-  vector("list", length = ngroups)
        for (g in seq_len(ngroups)) {
          lavobject@SampleStats@group.w[[g]] <-
            lavobject@SampleStats@nobs[[g]] / lavobject@SampleStats@ntotal
        }
      }
      if (!.hasSlot(lavobject@Model, "group.w.free")) {
        lavobject@Model@group.w.free <- FALSE
      }
      if (!.hasSlot(lavobject@Model, "parameterization")) {
        lavobject@Model@parameterization <- "delta"
      }
      if (!.hasSlot(lavobject@Model, "link")) {
        lavobject@Model@link <- "default"
      }
    }

    # 0.5-17 (30 Sept 2014)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@SampleStats, "WLS.VD")) {
        lavobject@SampleStats@WLS.VD <- vector("list", length = ngroups)
      }
    }

    # 0.5-18 (18 Nov 2014)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@Model, "eq.constraints.k0")) {
        lavobject@Model@eq.constraints.k0 <- numeric(0L)
      }
      if (!.hasSlot(lavobject@Model, "ceq.linear.idx")) {
        lavobject@Model@ceq.linear.idx <- integer(0L)
        lavobject@Model@ceq.nonlinear.idx <- integer(0L)
        lavobject@Model@cin.linear.idx <- integer(0L)
        lavobject@Model@cin.nonlinear.idx <- integer(0L)
      }
    }

    # 0.5-18 (13 Jan 2015)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@Model, "ceq.JAC")) {
        lavobject@Model@ceq.JAC <- matrix(0, nrow = 0L,
                                            ncol = lavobject@Model@nx.free)
        lavobject@Model@ceq.rhs <- numeric(0L)
        lavobject@Model@cin.JAC <- matrix(0, nrow = 0L,
                                            ncol = lavobject@Model@nx.free)
        lavobject@Model@cin.rhs <- numeric(0L)
      }
    }

    # 0.5-19 (30 Jul 2015)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject, "boot")) {
        # construct partial optim list
        optim_list <- list(x = lavobject@Fit@x,
                           dx = numeric(0L),
                           npar = lavobject@Fit@npar,
                           iterations = lavobject@Fit@iterations,
                           converged = lavobject@Fit@converged,
                           warn.txt = "",
                           parscale = rep(1, lavobject@Fit@npar),
                           fx = lavobject@Fit@fx,
                           fx.group = lavobject@Fit@fx.group,
                           logl.group = lavobject@Fit@logl.group,
                           control = lavobject@Fit@control)
        lavobject@boot <- vector("list", 0L)
        lavobject@optim <- optim_list
        lavobject@implied <- lav_model_implied(lavobject@Model)
        lavobject@vcov <- list(se = lavobject@Options$se[1],
                               information = lavobject@Options$information[1],
                               vcov = matrix(0, 0, 0)) # for now
        lavobject@test <- lavTest(lavobject)
        lavobject@external <- vector("list", 0L)
      }
    }

    # 0.5-19: est/se move to @ParTable
    if (!is.null(lavobject@Fit@est) && is.null(lavobject@ParTable$est)) {
      lavobject@ParTable$est <- lavobject@Fit@est
    }
    if (!is.null(lavobject@Fit@se) && is.null(lavobject@ParTable$se)) {
      lavobject@ParTable$se <- lavobject@Fit@se
    }


    # 0.5-21 (16 Dec 2015)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@Model, "conditional.x")) {
        lavobject@Model@conditional.x <- FALSE
      }
    }

    # 0.5-21 (5 Jan 2016)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@SampleStats, "x.idx")) {
        lavobject@SampleStats@x.idx <- rep(list(integer(0L)), ngroups)
      }
    }

    # 0.5-21 (8 Jan 2016)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@SampleStats, "res.cov")) {
        lavobject@SampleStats@res.cov <- vector("list", ngroups)
        lavobject@SampleStats@res.var <- vector("list", ngroups)
        lavobject@SampleStats@res.th <- vector("list", ngroups)
        lavobject@SampleStats@res.th.nox <- vector("list", ngroups)
        lavobject@SampleStats@res.slopes <- vector("list", ngroups)
        lavobject@SampleStats@res.int <- vector("list", ngroups)
        lavobject@SampleStats@res.icov <- vector("list", ngroups)
        lavobject@SampleStats@res.icov.log.det <- vector("list", ngroups)
      }
    }

    # 0.5-21 (28 Mar 2016)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@SampleStats, "NACOV.user")) {
        lavobject@SampleStats@NACOV.user <- FALSE
      }
    }

    #### 0.5-21, 3 Jul 2016, Class lavaanList is added ####

    # 0.5-23 (25 Jan 2017)
    if (!.hasSlot(lavobject@Model, "estimator")) {
      lavobject@Model@estimator <- lavobject@Options$estimator
    }

    # 0.5-23 (30 Jan 2017)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@Data, "cluster")) {
        lavobject@Data@cluster <- character(0L)
        lavobject@Data@ordered <- character(0L)
      }
    } else {
      for (j in seq_along(lavobject@DataList)) {
        if (!.hasSlot(lavobject@DataList[[j]], "cluster")) {
          lavobject@DataList[[j]]@cluster <- character(0L)
          lavobject@DataList[[j]]@ordered <- character(0L)
        }
      }
    }

    # 0.5-23 (7 Feb 2017)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@SampleStats, "zero.cell.tables")) {
        lavobject@SampleStats@zero.cell.tables <- vector("list", ngroups)
      }
    } else {
      for (j in seq_along(lavobject@SampleStatsList)) {
        if (!.hasSlot(lavobject@SampleStatsList[[j]], "zero.cell.tables")) {
          lavobject@SampleStatsList[[j]]@zero.cell.tables <- vector("list", ngroups)
        }
      }
    }

    # 0.5-23 (21 Feb 2017)
    if (!.hasSlot(lavobject@Model, "nblocks")) {
      lavobject@Model@nblocks <- nblocks
    }
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@Data, "level.label")) {
        lavobject@Data@level.label <- as.character(seq.int(nlevels))
      }
    } else {
      for (j in seq_along(lavobject@DataList)) {
        if (!.hasSlot(lavobject@DataList[[j]], "level.label")) {
          lavobject@DataList[[j]]@level.label <- as.character(seq.int(nlevels))
        }
      }
    }
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@Data, "block.label")) {
        if (nlevels <= 1L) {
          if (ngroups <= 1L) {
            lavobject@Data@block.label <- character(0L)
          } else {
            lavobject@Data@block.label <- lavobject@Data@group.label
          }
        } else {
          if (ngroups <= 1L) {
            lavobject@Data@block.label <- lavobject@Data@level.label
          } else {
            lavobject@Data@block.label <-
              paste(rep(lavobject@Data@group.label,
                        each = length(lavobject@Data@level.label)),
                    rep(lavobject@Data@level.label,
                        times = length(lavobject@Data@group.label)),
                    sep = "."
              )
          }
        }
      }
    } else {
      for (j in seq_along(lavobject@DataList)) {
        if (!.hasSlot(lavobject@DataList[[j]], "block.label")) {
          if (nlevels <= 1L) {
            if (ngroups <= 1L) {
              lavobject@DataList[[j]]@block.label <- character(0L)
            } else {
              lavobject@DataList[[j]]@block.label <-
                lavobject@DataList[[j]]@group.label
            }
          } else {
            if (ngroups <= 1L) {
              lavobject@DataList[[j]]@block.label <-
                lavobject@DataList[[j]]@level.label
            } else {
              lavobject@DataList[[j]]@block.label <-
                paste(rep(lavobject@DataList[[j]]@group.label,
                          each = length(lavobject@DataList[[j]]@level.label)),
                      rep(lavobject@DataList[[j]]@level.label,
                          times = length(lavobject@DataList[[j]]@group.label)),
                      sep = "."
                )
            }
          }
        }
      }
    }

    # 0.5-23 (24 Feb 2017)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@Data, "nlevels")) {
        lavobject@Data@nlevels <- nlevels
        lavobject@Data@Lp <- vector("list", ngroups)
      }
    } else {
      for (j in seq_along(lavobject@DataList)) {
        if (!.hasSlot(lavobject@DataList[[j]], "nlevels")) {
          lavobject@DataList[[j]]@nlevels <- nlevels
          lavobject@DataList[[j]]@Lp <- vector("list", ngroups)
        }
      }
    }
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@SampleStats, "YLp")) {
        lavobject@SampleStats@YLp <- vector("list", ngroups)
      }
    } else {
      for (j in seq_along(lavobject@SampleStatsList)) {
        if (!.hasSlot(lavobject@SampleStatsList[[j]], "YLp")) {
          lavobject@SampleStatsList[[j]]@YLp <- vector("list", ngroups)
        }
      }
    }

    # 0.6-1 (8 Mar 2017)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject, "h1")) {
        lavobject@h1 <- lav_h1_implied_logl(lavdata = lavobject@Data,
          lavsamplestats = lavobject@SampleStats,
          lavpartable = lavobject@ParTable,
          lavoptions = lavobject@Options)
        lavobject@baseline <- lav_lavaan_step15_baseline(
          lavoptions = lavobject@Options,
          lavsamplestats = lavobject@SampleStats,
          lavdata = lavobject@Data,
          lavcache = lavobject@Cache,
          lavpartable = lavobject@ParTable
        )
      }
      if (!.hasSlot(lavobject@Data, "ov.names.l")) {
        lavobject@Data@ov.names.l <- vector("list", 0L)
      }
    } else {
      for (j in seq_along(lavobject@DataList)) {
        if (!.hasSlot(lavobject@DataList[[j]], "ov.names.l")) {
          lavobject@DataList[[j]]@ov.names.l <- vector("list", 0L)
        }
      }
    }

    # 0.6-1 (10 Mar 2017)
    if (!.hasSlot(lavobject@Model, "multilevel")) {
      lavobject@Model@multilevel <- FALSE
    }

    # 0.6-1 (19 Mar 2017)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject, "loglik")) {
        lavobject@Model@ceq.simple.only <- FALSE
        lavobject@Model@cin.simple.only <- FALSE
        lavobject@loglik <- lav_model_loglik(
          lavdata = lavobject@Data,
          lavsamplestats = lavobject@SampleStats,
          lavimplied = lavobject@implied,
          lavmodel = lavobject@Model,
          lavoptions = lavobject@Options
        )
      }
    }

    # 0.6-1 (1 Oct 2017)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@Data, "weights")) {
        lavobject@Data@weights <- vector("list", ngroups)
      }
    } else {
      for (j in seq_along(lavobject@DataList)) {
        if (!.hasSlot(lavobject@DataList[[j]], "weights")) {
          lavobject@DataList[[j]]@weights <- vector("list", ngroups)
        }
      }
    }

    # 0.6-1 (3 Oct 2017)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject@Data, "sampling.weights")) {
        lavobject@Data@sampling.weights <- character(0L)
      }
    } else {
      for (j in seq_along(lavobject@DataList)) {
        if (!.hasSlot(lavobject@DataList[[j]], "sampling.weights")) {
          lavobject@DataList[[j]]@sampling.weights <- character(0L)
        }
      }
    }

    # 0.6-1 (2 May 2018)
    if (is.lavaan.object) {
      if (!.hasSlot(lavobject, "version")) lavobject@version <- "PRE 0.6"
    }
  } # no-version-flag (pre 0.6)

  ### from here on, we assume that the object is generated by lavaan 0.6-1 or
  ### higher

  # check if @test list is named
  if (is.null(names(lavobject@test))) {
    names(lavobject@test) <- sapply(lavobject@test, "[[", "test")
  }

  # 0.6-2 (12 Jun 2018)
  if (!.hasSlot(lavobject@Model, "x.free.var.idx")) {
    lavobject@Model@x.free.var.idx <- integer(0L)
  }

  # 0.6-3 (17 Sep 2018)
  if (!is.lavaan.object) {
    if (!.hasSlot(lavobject, "h1List")) {
      lavobject@h1List <- vector("list", 0L)
      lavobject@loglikList <- vector("list", 0L)
    }
  }

  # 0.6-4 (30 Mar 2019)
  if (!.hasSlot(lavobject@Model, "ov.efa.idx")) {
    lavobject@Model@ov.efa.idx <- vector("list", nblocks)
    lavobject@Model@lv.efa.idx <- vector("list", nblocks)
  }

  # 0.6-4 (11 Apr 2019)
  if (!.hasSlot(lavobject@Model, "nefa")) {
    lavobject@Model@nefa <- 0L
  }

  # 0.6-4 (24 Apr 2019)
  if (!.hasSlot(lavobject@Model, "H")) {
    lavobject@Model@H <- vector("list", 0L)
    lavobject@Model@lv.order <- vector("list", 0L)
  }

  # 0.6-4 (26 Apr 2019)
  if (!.hasSlot(lavobject@Model, "ceq.efa.JAC")) {
    lavobject@Model@ceq.efa.JAC <- matrix(0, nrow = 0L, ncol = 0L)
  }

  # 0.6-5 (7 Jul 2019)
  if (!is.lavaan.object) {
    if (!.hasSlot(lavobject, "baselineList")) {
      lavobject@baselineList <- vector("list", 0L)
    }
  }

  # 0.6-8 (29 Sep 2020)
  if (!.hasSlot(lavobject@Model, "rv.ov")) {
    lavobject@Model@rv.ov <- vector("list", 0L)
    lavobject@Model@rv.lv <- vector("list", 0L)
  }

  # 0.6-8 (18 Dec 2020)
  if (!.hasSlot(lavobject@Model, "estimator.args")) {
    lavobject@Model@estimator.args <- vector("list", 0L)
  }

  # 0.6-9 (15 Mar 2021)
  if (!.hasSlot(lavobject@Model, "modprop")) {
    lavobject@Model@modprop = lav_model_properties(
      GLIST = lavobject@Model@GLIST,
      lavpartable = lavobject@ParTable,
      nmat = lavobject@Model@nmat,
      m.free.idx = lavobject@Model@m.free.idx
    )
  }

  # 0.6-9 (22 Jun 2021)
  if (is.lavaan.object) {
    if (!.hasSlot(lavobject, "internal")) {
      lavobject@internal <- vector("list", 0L)
    }
  } else {
    if (!.hasSlot(lavobject, "internalList")) {
      lavobject@internalList <- vector("list", 0L)
    }
  }

  # 0.6-11 (28 Feb 2022)
  if (!.hasSlot(lavobject@Model, "nx.unco")) {
    # is not available, unco == free
    lavobject@Model@nx.unco <- lavobject@Model@nx.free
    lavobject@Model@x.unco.idx <- lavobject@Model@x.free.idx
    lavobject@Model@ceq.simple.only <- FALSE
    lavobject@Model@ceq.simple.K <- matrix(0, nrow = 0L, ncol = 0L)
  }

  # 0.6-13 (25 Jul 2022)
  if (!.hasSlot(lavobject@Model, "correlation")) {
    lavobject@Model@correlation <- FALSE
  }

  # 0.6-18 (25 Apr 2024)
  if (!is.lavaan.object) {
    if (!.hasSlot(lavobject, "version")) {
      lavobject@version <- "PRE 0.6.18"
    }
  }

  # 0.6-19 (27 Sep 2024)
  if (!.hasSlot(lavobject@Model, "cin.simple.only")) {
    lavobject@Model@cin.simple.only <- FALSE
  }

  # 0.6-20 (24 Jan 2025)
  if (!.hasSlot(lavobject@Model, "composites")) {
    lavobject@Model@composites <- any(lavobject@ParTable$op == "<~")
  }

  # check missing options
  object_options <- lavobject@Options
  all_options <- lavOptions()
  missing.idx <- which(!names(all_options) %in% names(object_options))
  new_options <- c(object_options, all_options[missing.idx])
  # fill in some "default" values
  if (new_options$estimator.orig == "default") {
    new_options$estimator.orig <- new_options$estimator
  }

  # 0.6-21
  new_options$gamma.vcov.mplus <- new_options$mimic == "Mplus"
  new_options$gamma.wls.mplus <- new_options$mimic == "Mplus"
  new_options$gls.v11.mplus <- new_options$mimic == "Mplus"
  new_options$cinformation.expected.mplus <- new_options$mimic == "Mplus"
  new_options$h1.information.meat <- "structured"
  new_options$mega.h1.information <- "unstructured"

  # 0.6-22
  if (is.null(new_options$rotation.args$mg.agreement)) {
    new_options$rotation.args$mg.agreement <- FALSE
    new_options$rotation.args$mg.agreement.weight <- 0.5
    new_options$rotation.args$mg.agreement.method <- "pairwise"
    ew_options$rotation.args$mg.agreement.crit    <- "procrustes"

  }
  if (is.null(new_options$rotation.args$mg.agreement.weight)) {
    new_options$rotation.args$mg.agreement.weight <- 0.5
  }

  lavobject@Options <- new_options

  lavobject
}

# RAM representation
#
# initial version: YR 2021-10-04

lav_ram <- function(partable = NULL,
                    target = NULL,
                    extra = FALSE,
                    remove.nonexisting = TRUE) {
  # prepare target list
  if (is.null(target)) target <- partable

  stopifnot(!is.null(target$block))

  # not for categorical data (yet)
  if (any(partable$op == "|")) {
    lav_msg_stop(gettext("RAM representation is not (yet) supported for
                         categorical endogenous variables."))
  }

  # not for conditional.x = TRUE yet
  conditional.x <- any(partable$exo > 0L & partable$op == "~")
  if (conditional.x) {
    lav_msg_stop(gettext("RAM representation is not (yet) supported
                         if conditional.x = TRUE"))
  }

  # prepare output
  N <- length(target$lhs)
  tmp.mat <- character(N)
  tmp.row <- integer(N)
  tmp.col <- integer(N)

  # global settings
  meanstructure <- any(partable$op == "~1")
  categorical <- any(partable$op == "|")
  group.w.free <- any(partable$lhs == "group" & partable$op == "%")

  # number of blocks
  nblocks <- lav_partable_nblocks(partable)

  # always return ov.idx
  ov.idx <- vector("list", nblocks)
  ov.dummy.names.nox <- vector("list", nblocks)
  ov.dummy.names.x <- vector("list", nblocks)
  if (extra) {
    REP.mmNames <- vector("list", nblocks)
    REP.mmNumber <- vector("list", nblocks)
    REP.mmRows <- vector("list", nblocks)
    REP.mmCols <- vector("list", nblocks)
    REP.mmDimNames <- vector("list", nblocks)
    REP.mmSymmetric <- vector("list", nblocks)
  }

  for (g in 1:nblocks) {
    # info from user model per block
    ov.names <- lav_partable_vnames(partable, "ov", block = g)
    nvar <- length(ov.names)
    ov.idx[[g]] <- seq_len(nvar)
    ov.dummy.names.nox[[g]] <- character(0)
    ov.dummy.names.x[[g]] <- character(0)

    lv.names <- lav_partable_vnames(partable, "lv", block = g)
    both.names <- c(ov.names, lv.names)
    nboth <- length(both.names)

    # 1. "=~" indicators
    idx <- which(target$block == g & target$op == "=~")
    tmp.mat[idx] <- "A"
    tmp.row[idx] <- match(target$rhs[idx], both.names)
    tmp.col[idx] <- match(target$lhs[idx], both.names)

    # 2. "~" regressions
    idx <- which(target$block == g & (target$op == "~" |
      target$op == "<~"))
    tmp.mat[idx] <- "A"
    tmp.row[idx] <- match(target$lhs[idx], both.names)
    tmp.col[idx] <- match(target$rhs[idx], both.names)

    # 3. "~~" variances/covariances
    idx <- which(target$block == g & target$op == "~~")
    tmp.mat[idx] <- "S"
    tmp.row[idx] <- match(target$lhs[idx], both.names)
    tmp.col[idx] <- match(target$rhs[idx], both.names)

    # catch lower-elements in theta/psi
    idx.lower <- which(tmp.mat == "S" & tmp.row > tmp.col)
    if (length(idx.lower) > 0L) {
      tmp <- tmp.row[idx.lower]
      tmp.row[idx.lower] <- tmp.col[idx.lower]
      tmp.col[idx.lower] <- tmp
    }

    # 4. "~1" means/intercepts
    idx <- which(target$block == g & target$op == "~1")
    tmp.mat[idx] <- "m"
    tmp.row[idx] <- match(target$lhs[idx], both.names)
    tmp.col[idx] <- 1L

    # 5. "|" th
    # not used yet

    # 6. "~*~" scales
    # not used yet

    # 7. group weights
    idx <- which(target$block == g & target$lhs == "group" &
      target$op == "%")
    tmp.mat[idx] <- "gw"
    tmp.row[idx] <- 1L
    tmp.col[idx] <- 1L

    if (extra) {
      # mRows
      mmRows <- list(
        ov.idx = 1L,
        A = nboth,
        S = nboth,
        m = nboth,
        gw = 1L
      )

      # mCols
      mmCols <- list(
        ov.idx = nvar,
        A = nboth,
        S = nboth,
        m = 1L,
        gw = 1L
      )

      # dimNames for LISREL model matrices
      mmDimNames <- list(
        ov.idx = list("ov.idx", ov.names),
        A = list(both.names, both.names),
        S = list(both.names, both.names),
        m = list(both.names, "intercept"),
        gw = list("group", "weight")
      )
      # isSymmetric
      mmSymmetric <- list(
        ov.idx = FALSE,
        A = FALSE,
        S = TRUE,
        m = FALSE,
        gw = FALSE
      )

      # which mm's do we need? (always include ov.idx, A and S)
      IDX <- which(target$block == g)
      mmNames <- c("ov.idx", "A", "S")
      if (meanstructure) {
        mmNames <- c(mmNames, "m")
      }
      if ("gw" %in% tmp.mat[IDX]) {
        mmNames <- c(mmNames, "gw")
      }

      REP.mmNames[[g]] <- mmNames
      REP.mmNumber[[g]] <- length(mmNames)
      REP.mmRows[[g]] <- unlist(mmRows[mmNames])
      REP.mmCols[[g]] <- unlist(mmCols[mmNames])
      REP.mmDimNames[[g]] <- mmDimNames[mmNames]
      REP.mmSymmetric[[g]] <- unlist(mmSymmetric[mmNames])
    } # extra
  } # nblocks

  REP <- list(
    mat = tmp.mat,
    row = tmp.row,
    col = tmp.col
  )

  # always return ov.idx attribute
  attr(REP, "ov.idx") <- ov.idx
  attr(REP, "ov.dummy.names.nox") <- ov.dummy.names.nox
  attr(REP, "ov.dummy.names.x") <- ov.dummy.names.x

  if (extra) {
    attr(REP, "mmNames") <- REP.mmNames
    attr(REP, "mmNumber") <- REP.mmNumber
    attr(REP, "mmRows") <- REP.mmRows
    attr(REP, "mmCols") <- REP.mmCols
    attr(REP, "mmDimNames") <- REP.mmDimNames
    attr(REP, "mmSymmetric") <- REP.mmSymmetric
  }

  REP
}

# the model-implied variance/covariance matrix of the observed variables
lav_ram_sigmahat <- function(MLIST = NULL, delta = NULL) {
  ov.idx <- as.integer(MLIST$ov.idx[1, ])
  A <- MLIST$A
  S <- MLIST$S

  # get (I-A)^{-1}
  IA.inv <- lav_matrix_inverse_iminus(A)

  # compute Sigma for all ov and lv
  VYeta <- tcrossprod(IA.inv %*% S, IA.inv)

  # select only observed part
  VY <- VYeta[ov.idx, ov.idx, drop = FALSE]

  # if delta, scale
  if (!is.null(MLIST$delta) && delta) {
    nvar <- ncol(VY)
    DELTA <- diag(MLIST$delta[, 1L], nrow = nvar, ncol = nvar)
    VY <- DELTA %*% VY %*% DELTA
  }

  VY
}

# VETA: the variance/covariance matrix of the latent variables only
lav_ram_veta <- function(MLIST = NULL) {
  ov.idx <- as.integer(MLIST$ov.idx[1, ])
  A <- MLIST$A
  S <- MLIST$S

  # get (I-A)^{-1}
  IA.inv <- lav_matrix_inverse_iminus(A)

  # compute Sigma for all ov and lv
  VYeta <- tcrossprod(IA.inv %*% S, IA.inv)

  # select only latent part
  VETA <- VYeta[-ov.idx, -ov.idx, drop = FALSE]

  VETA
}

# MuHat: the model-implied means/intercepts
lav_ram_muhat <- function(MLIST = NULL) {
  ov.idx <- as.integer(MLIST$ov.idx[1, ])
  A <- MLIST$A
  m <- MLIST$m

  # shortcut
  if (is.null(m)) {
    return(matrix(0, nrow = length(ov.idx), 1L))
  }

  # get (I-A)^{-1}
  IA.inv <- lav_matrix_inverse_iminus(A)

  # all means/intercepts
  EYeta <- IA.inv %*% m

  # select observed only
  muhat <- EYeta[ov.idx, , drop = FALSE]

  muhat
}

# derivative of 'Sigma' wrt the (freel) elements in A and/or S
lav_ram_dsigma <- function(m = "A",
                           idx = seq_len(length(MLIST[[m]])),
                           MLIST = NULL,
                           vech = TRUE) {
  ov.idx <- as.integer(MLIST$ov.idx[1, ])
  A <- MLIST$A
  S <- MLIST$S

  nvar <- length(ov.idx)
  nboth <- nrow(A)

  # shortcut for ov.idx, m, ...
  if (!m %in% c("A", "S")) {
    pstar <- nvar * (nvar + 1) / 2
    return(matrix(0.0, nrow = pstar, ncol = length(idx)))
  }

  # get (I-A)^{-1}
  IA.inv <- lav_matrix_inverse_iminus(A)

  if (m == "A") {
    L1 <- (IA.inv %*% S %*% t(IA.inv))[ov.idx, , drop = FALSE]
    KOL.idx <- matrix(1:(nboth * nboth), nboth, nboth, byrow = TRUE)[idx]
    DX <- (L1 %x% IA.inv[ov.idx, , drop = FALSE])[, idx, drop = FALSE] +
      (IA.inv[ov.idx, , drop = FALSE] %x% L1)[, KOL.idx, drop = FALSE]
    # this is not really needed (because we select idx=m.el.idx)
    # but just in case we need all elements of beta...
    DX[, which(idx %in% lav_matrix_diag_idx(nboth))] <- 0.0
  } else if (m == "S") {
    DX <- (IA.inv[ov.idx, , drop = FALSE] %x% IA.inv[ov.idx, , drop = FALSE])
    # symmetry correction, but keeping all duplicated elements
    # since we depend on idx=m.el.idx
    lower.idx <- lav_matrix_vech_idx(nboth, diagonal = FALSE)
    upper.idx <- lav_matrix_vechru_idx(nboth, diagonal = FALSE)
    offdiagSum <- DX[, lower.idx] + DX[, upper.idx]
    DX[, c(lower.idx, upper.idx)] <- cbind(offdiagSum, offdiagSum)
    DX <- DX[, idx, drop = FALSE]
  } else {
    lav_msg_stop(gettext("wrong model matrix names:"), m)
  }

  # vech?
  if (vech) {
    v.idx <- lav_matrix_vech_idx(nvar)
    DX <- DX[v.idx, , drop = FALSE]
  }

  DX
}

# derivative of 'Mu' wrt the (free) elements in A and/or m
lav_ram_dmu <- function(m = "A",
                        idx = seq_len(length(MLIST[[m]])),
                        MLIST = NULL,
                        vech = TRUE) {
  ov.idx <- as.integer(MLIST$ov.idx[1, ])
  A <- MLIST$A
  S <- MLIST$S

  nvar <- length(ov.idx)
  nboth <- nrow(A)

  # shortcut for ov.idx, m, ...
  if (!m %in% c("A", "m")) {
    return(matrix(0.0, nrow = nvar, ncol = length(idx)))
  }

  # get (I-A)^{-1}
  IA.inv <- lav_matrix_inverse_iminus(A)

  if (m == "A") {
    DX <- (t(IA.inv %*% MLIST$m) %x% IA.inv)[ov.idx, idx, drop = FALSE]
  } else if (m == "m") {
    DX <- IA.inv[ov.idx, idx, drop = FALSE]
  } else {
    lav_msg_stop(gettext("wrong model matrix names:"), m)
  }

  DX
}

# derivative of ML/GLS objective function F wrt the free parameters
lav_ram_df <- function(MLIST = NULL, Omega = NULL, Omega.mu = NULL) {
  ov.idx <- as.integer(MLIST$ov.idx[1, ])
  A <- MLIST$A
  S <- MLIST$S

  nvar <- length(ov.idx)
  nboth <- nrow(A)

  # get (I-A)^{-1}
  IA.inv <- lav_matrix_inverse_iminus(A)

  # meanstructure?
  meanstructure <- FALSE
  if (!is.null(Omega.mu)) meanstructure <- TRUE

  # pre-compute
  tIA.inv <- t(IA.inv)
  Omega..IA.inv..S..tIA.inv <- (Omega %*% IA.inv[ov.idx, , drop = FALSE] %*% S %*% t(IA.inv))

  # 1. A
  if (meanstructure) {
    A.deriv <-
      -1.0 * ((t(IA.inv)[, ov.idx, drop = FALSE] %*% (Omega.mu %*% t(MLIST$m)) %*% t(IA.inv)) +
        (tIA.inv[, ov.idx, drop = FALSE] %*% Omega..IA.inv..S..tIA.inv))
  } else {
    A.deriv <- -1.0 * (tIA.inv[, ov.idx, drop = FALSE] %*% Omega..IA.inv..S..tIA.inv)
  }

  # 2. S
  S.deriv <- -1.0 * (tIA.inv[, ov.idx, drop = FALSE] %*% Omega %*% IA.inv[ov.idx, , drop = FALSE])
  diag(S.deriv) <- 0.5 * diag(S.deriv)

  if (meanstructure) {
    m.deriv <- -1.0 * t(t(Omega.mu) %*% IA.inv[ov.idx, , drop = FALSE])
  } else {
    m.deriv <- NULL
  }

  list(
    A = A.deriv,
    S = S.deriv,
    m = m.deriv
  )
}

# Factor extraction method(s)
# YR Feb 2020
#
# - ULS_corner only (for now)
# - just to get better starting values for ESEM

# YR July 2020
# - adding generic function lav_efa_extraction, using eigenvalue based
#   approach; ML and ULS
# - 'corner' is an option

lav_efa_extraction <- function(S, nfactors = 1L,
                               method = "ULS", # or ML
                               corner = FALSE,
                               reflect = FALSE, order.lv.by = "none",
                               min.var = 0.0001) {
  stopifnot(is.matrix(S))
  S <- unname(S)
  method <- tolower(method)

  # extract variances
  S.var <- diag(S)

  # force S to be pd (eg if we have polychoric correlations)
  S <- lav_matrix_symmetric_force_pd(S, tol = 1e-08)

  # convert to correlation matrix (ULS is not scale invariant!)
  R <- cov2cor(S)

  # optim.method
  if (method == "uls") {
    minObjective <- lav_efa_uls_min_objective
    minGradient <- lav_efa_uls_min_gradient
    cache <- lav_efa_uls_init_cache(R = R, nfactors = nfactors)
  } else if (method == "ml") {
    minObjective <- lav_efa_ml_min_objective
    minGradient <- lav_efa_ml_min_gradient
    cache <- lav_efa_ml_init_cache(R = R, nfactors = nfactors)
  } else {
    lav_msg_stop(gettext("method must be uls or ml (for now)"))
  }
  minHessian <- NULL

  # optimize
  control.nlminb <- list(
    eval.max = 20000L, iter.max = 10000L,
    trace = if (lav_verbose()) {
      1L
    } else {
      0L
    },
    abs.tol = (.Machine$double.eps * 10)
  )
  if (lav_verbose()) {
    cat("\n")
    cat("factor extraction iterations using ", method, ":\n")
  }
  out <- nlminb(
    start = cache$theta, objective = minObjective,
    gradient = minGradient, hessian = minHessian,
    control = control.nlminb, lower = min.var, upper = +1,
    cache = cache
  )

  # extract LAMBDA/THETA
  if (method == "uls") {
    THETA <- diag(out$par * out$par)

    # compute LAMBDA
    A <- R
    diag(A) <- diag(A) - (out$par * out$par)
    EV <- eigen(A, symmetric = TRUE)
    Omega.1 <- EV$vectors[, 1:nfactors]
    gamma.1 <- EV$values[1:nfactors]

    # LAMBDA <- Omega.1 %*% diag(sqrt(gamma.1))
    LAMBDA <- t(t(Omega.1) * sqrt(gamma.1))

    # rescale if the input matrix was not a correlation matrix
    LAMBDA <- sqrt(S.var) * LAMBDA
    diag(THETA) <- S.var * diag(THETA)
  } else if (method == "ml") {
    THETA <- diag(out$par * out$par)

    # compute LAMBDA
    psi <- out$par
    A <- t(psi * cache$R.inv) * psi
    EV <- eigen(A, symmetric = TRUE)
    Omega.1 <- EV$vectors[, 1L + cache$nvar - seq_len(cache$nfactors),
      drop = FALSE
    ]
    gamma.1 <- EV$values[1L + cache$nvar - seq_len(cache$nfactors)]

    # LAMBDA <- diag(psi) %*% Omega.1 %*%sqrt(solve(Gamma.1)-diag(nfactors))
    tmp1 <- psi * Omega.1
    LAMBDA <- t(t(tmp1) * sqrt((1 / gamma.1) - 1))

    # rescale if the input matrix was not a correlation matrix
    LAMBDA <- sqrt(S.var) * LAMBDA
    diag(THETA) <- S.var * diag(THETA)
  }

  # corner?
  if (corner) {
    # rotate to echelon pattern (see echelon() in GPArotation package)
    HEAD <- LAMBDA[seq_len(nfactors), , drop = FALSE]
    POST <- try(solve(HEAD, t(chol(tcrossprod(HEAD)))), silent = TRUE)
    okflag <- FALSE
    if (inherits(POST, "try-error")) { # new in 0.6-18
      # this will happen if we have identical elements in the columns
      # of HEAD (perhaps the data is artificial?)
      # -> add some fuzz and try again
      SD <- sqrt(mean(abs(HEAD))) * 1e-04
      fuzz <- matrix(rnorm(nfactors * nfactors, 0, SD), nfactors, nfactors)
      HEAD2 <- HEAD + fuzz
      POST <- try(solve(HEAD2, t(chol(tcrossprod(HEAD2)))), silent = TRUE)
      if (!inherits(POST, "try-error")) {
        okflag <- TRUE
      }
    } else {
      okflag <- TRUE
    }
    if (okflag) {
      LAMBDA <- LAMBDA %*% POST
    } else {
      lav_msg_warn(gettext(
        "rotation of initial factor solution to echelon pattern failed."))
    }
  }

  # ALWAYS change the sign so that largest element in the column is positive
  # neg.max <- apply(LAMBDA, 2, function(x) { sign(x[which.max(abs(x))]) })
  # neg.idx <- which(neg.max < 0)
  # if(length(neg.idx) > 0L) {
  #    LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE]
  # }

  # ALWAYS change the sign so that diag(LAMBDA) is positive
  neg.idx <- which(diag(LAMBDA) < 0)
  if (length(neg.idx) > 0L) {
    LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE]
  }

  # reflect so that column sum is always positive
  if (reflect) {
    SUM <- colSums(LAMBDA)
    neg.idx <- which(SUM < 0)
    if (length(neg.idx) > 0L) {
      LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE]
    }
  }

  # reorder the columns
  if (order.lv.by == "sumofsquares") {
    L2 <- LAMBDA * LAMBDA
    order.idx <- base::order(colSums(L2), decreasing = TRUE)
  } else if (order.lv.by == "index") {
    # reorder using Asparouhov & Muthen 2009 criterion (see Appendix D)
    max.loading <- apply(abs(LAMBDA), 2, max)
    # 1: per factor, number of the loadings that are at least 0.8 of the
    #    highest loading of the factor
    # 2: mean of the index numbers
    average.index <- sapply(seq_len(ncol(LAMBDA)), function(i) {
      mean(which(abs(LAMBDA[, i]) >= 0.8 * max.loading[i]))
    })
    # order of the factors
    order.idx <- base::order(average.index)
  } else if (order.lv.by == "none") {
    order.idx <- seq_len(ncol(LAMBDA))
  } else {
    lav_msg_stop(gettext("order must be index, sumofsquares or none"))
  }
  LAMBDA <- LAMBDA[, order.idx, drop = FALSE]

  list(LAMBDA = LAMBDA, THETA = THETA)
}



lav_efa_uls_init_cache <- function(R = NULL,
                                          nfactors = 1L,
                                          parent = parent.frame()) {
  R.inv <- solve(R)
  nvar <- ncol(R)

  # starting values for diagonal elements of THETA
  # using Joreskog (1966) suggestion:
  theta.init <- (1 - nfactors / (2 * nvar)) * 1 / diag(R.inv)
  theta <- sqrt(theta.init)

  out <- list2env(
    list(
      R = R, nfactors = nfactors,
      theta = theta
    ),
    parent = parent
  )
  out
}

# x is here the sqrt() of theta!
lav_efa_uls_min_objective <- function(x, cache = NULL) {
  cache$theta <- x
  with(cache, {
    A <- R
    diag(A) <- diag(A) - (theta * theta)
    EV <- eigen(A, symmetric = TRUE, only.values = TRUE)
    gamma.2 <- EV$values[-seq_len(nfactors)]

    res <- 0.5 * sum(gamma.2 * gamma.2)
    return(res)
  })
}

lav_efa_uls_min_gradient <- function(x, cache = NULL) {
  # check if x has changed
  if (!all(x == cache$theta)) {
    cache$theta <- x
    # nothing to do
  }
  with(cache, {
    A <- R
    diag(A) <- diag(A) - (theta * theta)
    EV <- eigen(A, symmetric = TRUE)
    Omega.2 <- EV$vectors[, -seq_len(nfactors)]
    gamma.2 <- EV$values[-seq_len(nfactors)]

    res <- -2 * theta * colSums(t(Omega.2 * Omega.2) * gamma.2)
    return(res)
  })
}


# ML
lav_efa_ml_init_cache <- function(R = NULL,
                                         nfactors = 1L,
                                         parent = parent.frame()) {
  R.inv <- solve(R)
  nvar <- ncol(R)

  # starting values for diagonal elements of THETA
  # using Joreskog (1966) suggestion:
  theta.init <- (1 - nfactors / (2 * nvar)) * 1 / diag(R.inv)
  theta <- sqrt(theta.init)

  out <- list2env(
    list(
      R = R, nfactors = nfactors, R.inv = R.inv,
      nvar = nvar, # for ML only
      theta = theta
    ),
    parent = parent
  )
  out
}


# x is here the sqrt of theta
lav_efa_ml_min_objective <- function(x, cache = NULL) {
  cache$theta <- x
  with(cache, {
    psi <- theta
    # A <- diag(psi) %*% R.inv %*% diag(psi)
    A <- t(R.inv * psi) * psi
    EV <- eigen(A, symmetric = TRUE, only.values = TRUE)
    gamma.2 <- EV$values[(nvar - nfactors):1L]

    res <- sum(log(gamma.2) + 1 / gamma.2 - 1)
    return(res)
  })
}

lav_efa_ml_min_gradient <- function(x, cache = NULL) {
  # check if x has changed
  if (!all(x == cache$theta)) {
    cache$theta <- x
    # nothing to do
  }
  with(cache, {
    psi <- theta
    # A <- diag(psi) %*% solve(S) %*% diag(psi)
    A <- t(R.inv * psi) * psi
    EV <- eigen(A, symmetric = TRUE)

    omega.2 <- EV$vectors[, (nvar - nfactors):1L, drop = FALSE]
    gamma.2 <- EV$values[(nvar - nfactors):1L]

    res <- colSums(t(omega.2 * omega.2) * (1 - 1 / gamma.2))
    return(res)
  })
}




# ULS estimation
#
# - but resulting in a upper-corner all zeroes LAMBDA matrix
# - not using eigenvalues/vectors, but minimizing the residuals
#   directly

# - should give the same results as MINRES (after an orthogonal transformation)
# - unless there are heywood cases; this function allows for negative variances!

lav_efa_extraction_uls_corner <- function(S, nfactors = 1L, reflect = TRUE,
                                          order.lv.by = "none") {
  stopifnot(is.matrix(S))
  S <- unname(S)
  nvar <- nrow(S)

  # extract variances
  S.var <- diag(S)

  # convert to correlation matrix (ULS is not scale invariant!)
  R <- cov2cor(S)
  # R.inv <- solve(R)

  # eigenvalue decomposition (to get starting values for LAMBDA)
  EV <- eigen(R, symmetric = TRUE)

  # extract first nfac components (assuming no measurement error)
  PC <- (EV$vectors[, seq_len(nfactors), drop = FALSE] %*%
    diag(sqrt(EV$values[seq_len(nfactors)])))

  # rotate to echelon pattern (see echelon() in GPArotation package)
  HEAD <- PC[seq_len(nfactors), , drop = FALSE]
  LAMBDA <- PC %*% solve(HEAD, t(chol(tcrossprod(HEAD))))

  THETA <- diag(nvar)
  if (nfactors > 1L) {
    corner.idx <- which(row(LAMBDA) < nfactors & col(LAMBDA) > row(LAMBDA))
    lambda.idx <- seq_len(nvar * nfactors)[-corner.idx]
    LAMBDA[corner.idx] <- 0 # to make them exactly zero
  } else {
    corner.idx <- integer(0L)
    lambda.idx <- seq_len(nvar)
  }

  # optim.method
  minObjective <- lav_efa_uls_corner_min_objective
  minGradient <- lav_efa_uls_corner_min_gradient
  minHessian <- NULL

  # create cache environment
  cache <- lav_efa_uls_corner_init_cache(
    LAMBDA = LAMBDA,
    lambda.idx = lambda.idx, R = R
  )

  control.nlminb <- list(
    eval.max = 20000L, iter.max = 10000L,
    trace = if (lav_verbose()) {
      1L
    } else {
      0L
    },
    abs.tol = (.Machine$double.eps * 10)
  )

  # optimize
  out <- nlminb(
    start = cache$theta, objective = minObjective,
    gradient = minGradient, hessian = minHessian,
    control = control.nlminb, lower = -1, upper = +1,
    cache = cache
  )

  LAMBDA[lambda.idx] <- out$par
  diag(THETA) <- 1 - diag(tcrossprod(LAMBDA))

  # rescale if the input matrix was not a correlation matrix
  LAMBDA <- sqrt(S.var) * LAMBDA
  diag(THETA) <- S.var * diag(THETA)

  # reflect so that column sum is always positive
  if (reflect) {
    SUM <- colSums(LAMBDA)
    neg.idx <- which(SUM < 0)
    if (length(neg.idx) > 0L) {
      LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE]
    }
  }

  # reorder the columns
  if (order.lv.by == "sumofsquares") {
    L2 <- LAMBDA * LAMBDA
    order.idx <- base::order(colSums(L2), decreasing = TRUE)
  } else if (order.lv.by == "index") {
    # reorder using Asparouhov & Muthen 2009 criterion (see Appendix D)
    max.loading <- apply(abs(LAMBDA), 2, max)
    # 1: per factor, number of the loadings that are at least 0.8 of the
    #    highest loading of the factor
    # 2: mean of the index numbers
    average.index <- sapply(seq_len(ncol(LAMBDA)), function(i) {
      mean(which(abs(LAMBDA[, i]) >= 0.8 * max.loading[i]))
    })
    # order of the factors
    order.idx <- base::order(average.index)
  } else if (order.lv.by == "none") {
    order.idx <- seq_len(ncol(LAMBDA))
  } else {
    lav_msg_stop(gettext("order must be index, sumofsquares or none"))
  }
  LAMBDA <- LAMBDA[, order.idx, drop = FALSE]

  list(LAMBDA = LAMBDA, THETA = THETA)
}


lav_efa_uls_corner_init_cache <- function(LAMBDA = NULL,
                                                 lambda.idx = NULL,
                                                 R = NULL,
                                                 parent = parent.frame()) {
  theta <- LAMBDA[lambda.idx]
  out <- list2env(
    list(
      LAMBDA = LAMBDA,
      lambda.idx = lambda.idx,
      R = R,
      theta = theta
    ),
    parent = parent
  )
  out
}

lav_efa_uls_corner_min_objective <- function(x, cache = NULL) {
  cache$theta <- x
  with(cache, {
    LAMBDA[lambda.idx] <- theta
    res1 <- lav_matrix_vech(R - tcrossprod(LAMBDA), diagonal = FALSE)
    res2 <- res1 * res1
    return(sum(res2))
  })
}

lav_efa_uls_corner_min_gradient <- function(x, cache = NULL) {
  # check if x has changed
  if (!all(x == cache$theta)) {
    cache$theta <- x
    # nothing to do
  }
  with(cache, {
    LAMBDA[lambda.idx] <- theta
    Sigma <- tcrossprod(LAMBDA)
    diag(Sigma) <- 1 # diagonal is ignored
    tmp <- -2 * (R - Sigma) %*% LAMBDA
    return(tmp[lambda.idx])
  })
}

# parse lavaan syntax
# YR 14 Jan 2014: move to lav_syntax.R
# YR 17 Oct 2023: add ldw parser
# YR 23 Oct 2024: switch to "c.r"
# LDW 9 Jan 2026: remove c.r option

lavParseModelString <- function(model.syntax = "", as.data.frame. = FALSE,
                                parser = "new", warn = TRUE, debug = FALSE) {
  if (!missing(debug)) {
    current.debug <- lav_debug()
    if (lav_debug(debug))
      on.exit(lav_debug(current.debug), TRUE)
  }
  if (!missing(warn)) {
    current.warn <- lav_warn()
    if (lav_warn(warn))
      on.exit(lav_warn(current.warn), TRUE)
  }
  parser <- tolower(parser)
  if (!parser %in% c("old", "new")) {
    lav_msg_stop(gettext("parser= argument should
     be \"old\" or \"new\""))
  }

  if (parser == "old") {
    # original/classic parser
    out <- lav_parse_model_string_orig(
      model.syntax = model.syntax,
      as.data.frame. = as.data.frame.
    )
  } else {
    # new parser
    out <- lav_parse_model_string(
      model.syntax = model.syntax,
      as.data.frame. = as.data.frame.
      )
  }

  out
}

# the 'original' parser (up to 0.6-17)
lav_parse_model_string_orig <- function(model.syntax = "",
                                        as.data.frame. = FALSE) {
  # check for empty syntax
  if (length(model.syntax) == 0) {
    lav_msg_stop(gettextf("lavaan ERROR: empty model syntax"))
  }

  # remove comments prior to split:
  # match from comment character to newline, but don't eliminate newline
  model.syntax <- gsub("[#!].*(?=\n)", "", model.syntax, perl = TRUE)

  # replace semicolons with newlines prior to split
  model.syntax <- gsub(";", "\n", model.syntax, fixed = TRUE)

  # remove all whitespace prior to split
  model.syntax <- gsub("[ \t]+", "", model.syntax, perl = TRUE)
  # remove any occurrence of >= 2 consecutive newlines to eliminate
  # blank statements; this retains a blank newline at the beginning,
  # if such exists, but parser will not choke because of start.idx
  model.syntax <- gsub("\n{2,}", "\n", model.syntax, perl = TRUE)

  # replace 'strange' tildes (in some locales) (new in 0.6-6)
  model.syntax <- gsub(pattern = "\u02dc", replacement = "~", model.syntax)

  # break up in lines
  model <- unlist(strsplit(model.syntax, "\n"))

  # check for multi-line formulas: they contain no operator symbol
  # but before we do that, we remove all strings between double quotes
  # to avoid confusion with for example equal("f1=~x1") statements
  # model.simple <- gsub("\\(.*\\)\\*", "MODIFIER*", model)
  model.simple <- gsub("\\\".[^\\\"]*\\\"", "LABEL", model)

  # start.idx <- grep("[~=<>:|%]", model.simple)
  operators <- c(
    "=~", "<~", "~*~", "~~", "~", "==", "<", ">", ":=",
    ":", "\\|", "%"
  )
  lhs.modifiers <- c("efa")
  operators.extra <- c(operators, lhs.modifiers)
  start.idx <- grep(paste(operators.extra, collapse = "|"), model.simple)

  # check for empty start.idx: no operator found (new in 0.6-1)
  if (length(start.idx) == 0L) {
    lav_msg_stop(gettext("lavaan ERROR: model does not contain lavaan
                          syntax (no operators found)"))
  }

  # check for lonely lhs modifiers (only efa() for now):
  # if found, remove the following start.idx
  efa.idx <- grep("efa\\(", model.simple)
  op.idx <- grep(paste(operators, collapse = "|"), model.simple)
  both.idx <- which(efa.idx %in% op.idx)
  if (length(both.idx) > 0L) {
    efa.idx <- efa.idx[-which(efa.idx %in% op.idx)]
  }
  if (length(efa.idx) > 0L) {
    start.idx <- start.idx[-(match(efa.idx, start.idx) + 1L)]
  }

  # check for non-empty string, without an operator in the first lines
  # (new in 0.6-1)
  if (start.idx[1] > 1L) {
    # two possibilities:
    # - we have an empty line (ok)
    # - the element contains no operator (warn!)
    for (el in 1:(start.idx[1] - 1L)) {
      # not empty?
      if (nchar(model.simple[el]) > 0L) {
        lav_msg_warn(gettextf("lavaan WARNING: no operator found in this
                               syntax line: ", model.simple[el], "\n",
                              "     This syntax line will be ignored!"))
      }
    }
  }

  end.idx <- c(start.idx[-1] - 1, length(model))
  model.orig <- model
  model <- character(length(start.idx))
  for (i in seq_along(start.idx)) {
    model[i] <- paste(model.orig[start.idx[i]:end.idx[i]], collapse = "")
  }

  # ok, in all remaining lines, we should have an operator outside the ""
  model.simple <- gsub("\\\".[^\\\"]*\\\"", "LABEL", model)
  idx.wrong <- which(!grepl(
    paste(operators, collapse = "|"),
    model.simple
  ))
  # idx.wrong <- which(!grepl("[~=<>:|%]", model.simple))
  if (length(idx.wrong) > 0) {
    cat("lavaan: missing operator in formula(s):\n")
    print(model[idx.wrong])
    lav_msg_stop(gettext("lavaan ERROR: syntax error in lavaan model syntax"))
  }

  # but perhaps we have a '+' as the first character?
  idx.wrong <- which(grepl("^\\+", model))
  if (length(idx.wrong) > 0) {
    cat("lavaan: some formula(s) start with a plus (+) sign:\n")
    print(model[idx.wrong])
    lav_msg_stop(gettext("lavaan ERROR: syntax error in lavaan model syntax"))
  }


  # main operation: flatten formulas into single bivariate pieces
  # with a left-hand-side (lhs), an operator (eg "=~"), and a
  # right-hand-side (rhs)
  # both lhs and rhs can have a modifier
  FLAT.lhs <- character(0)
  FLAT.op <- character(0)
  FLAT.rhs <- character(0)
  FLAT.rhs.mod.idx <- integer(0)
  FLAT.block <- integer(0) # keep track of groups using ":" operator

  FLAT.fixed <- character(0) # only for display purposes!
  FLAT.start <- character(0) # only for display purposes!
  FLAT.lower <- character(0) # only for display purposes!
  FLAT.upper <- character(0) # only for display purposes!
  FLAT.label <- character(0) # only for display purposes!
  FLAT.prior <- character(0)
  FLAT.efa <- character(0)
  FLAT.rv <- character(0)
  FLAT.idx <- 0L
  MOD.idx <- 0L
  CON.idx <- 0L
  MOD <- vector("list", length = 0L)
  CON <- vector("list", length = 0L)
  BLOCK <- 1L
  BLOCK_OP <- FALSE
  for (i in seq_along(model)) {
    x <- model[i]
    if (lav_debug()) {
      cat("formula to parse:\n")
      print(x)
      cat("\n")
    }

    # 1. which operator is used?
    line.simple <- gsub("\\\".[^\\\"]*\\\"", "LABEL", x)
    # "=~" operator?
    if (grepl("=~", line.simple, fixed = TRUE)) {
      op <- "=~"
      # "<~" operator?
    } else if (grepl("<~", line.simple, fixed = TRUE)) {
      op <- "<~"
    } else if (grepl("~*~", line.simple, fixed = TRUE)) {
      op <- "~*~"
      # "~~" operator?
    } else if (grepl("~~", line.simple, fixed = TRUE)) {
      op <- "~~"
      # "~" operator?
    } else if (grepl("~", line.simple, fixed = TRUE)) {
      op <- "~"
      # "==" operator?
    } else if (grepl("==", line.simple, fixed = TRUE)) {
      op <- "=="
      # "<" operator?
    } else if (grepl("<", line.simple, fixed = TRUE)) {
      op <- "<"
      # ">" operator?
    } else if (grepl(">", line.simple, fixed = TRUE)) {
      op <- ">"
      # ":=" operator?
    } else if (grepl(":=", line.simple, fixed = TRUE)) {
      op <- ":="
      # ":" operator?
    } else if (grepl(":", line.simple, fixed = TRUE)) {
      op <- ":"
      # "|" operator?
    } else if (grepl("|", line.simple, fixed = TRUE)) {
      op <- "|"
      # "%" operator?
    } else if (grepl("%", line.simple, fixed = TRUE)) {
      op <- "%"
    } else {
      lav_msg_stop(gettext("unknown operator in ", model[i]))
    }

    # 2. split by operator (only the *first* occurence!)
    # check first if equal/label modifier has been used on the LEFT!
    if (substr(x, 1, 6) == "label(") {
      lav_msg_stop(gettext("label modifier can not be used on the left-hand side of the operator"))
    }
    if (op == "|") {
      op.idx <- regexpr("\\|", x)
    } else if (op == "~*~") {
      op.idx <- regexpr("~\\*~", x)
    } else {
      op.idx <- regexpr(op, x)
    }
    lhs <- substr(x, 1L, op.idx - 1L)

    # right-hand side string
    rhs <- substr(x, op.idx + attr(op.idx, "match.length"), nchar(x))

    # check if first character of rhs is '+'; if so, remove silently
    # (for those who copied multiline R input from a website/pdf)
    if (substr(rhs, 1, 1) == "+") {
      rhs <- substr(rhs, 2, nchar(rhs))
    }

    # 2b. if operator is "==" or "<" or ">" or ":=", put it in CON
    if (op == "==" || op == "<" || op == ">" || op == ":=") {
      # remove quotes, if any
      lhs <- gsub("\\\"", "", lhs)
      rhs <- gsub("\\\"", "", rhs)
      CON.idx <- CON.idx + 1L
      CON[[CON.idx]] <- list(op = op, lhs = lhs, rhs = rhs, user = 1L)
      next
    }

    # 2c if operator is ":", put it in BLOCK
    if (op == ":") {
      # check if rhs is empty (new in 0.6-4)
      if (nchar(rhs) == 0L) {
        lav_msg_stop(gettextf(
          "syntax contains block identifier %s with missing number/label. The
          correct syntax is: \"LHS: RHS\", where LHS is a block identifier (eg
          group or level), and RHS is the group/level/block number or label.",
          dQuote(lhs))
        )
      }

      # check lhs (new in 0.6-4) - note: class is for nlsem
      lhs.orig <- lhs
      lhs <- tolower(lhs)
      if (!lhs %in% c("group", "level", "block", "class")) {
        lav_msg_stop(gettextf(
          "unknown block identifier: %s. Block identifier should be
           group, level or block.", dQuote(lhs.orig))
        )
      }

      FLAT.idx <- FLAT.idx + 1L
      FLAT.lhs[FLAT.idx] <- lhs
      FLAT.op[FLAT.idx] <- op
      FLAT.rhs[FLAT.idx] <- rhs
      FLAT.fixed[FLAT.idx] <- ""
      FLAT.start[FLAT.idx] <- ""
      FLAT.lower[FLAT.idx] <- ""
      FLAT.upper[FLAT.idx] <- ""
      FLAT.label[FLAT.idx] <- ""
      FLAT.prior[FLAT.idx] <- ""
      FLAT.efa[FLAT.idx] <- ""
      FLAT.rv[FLAT.idx] <- ""
      FLAT.rhs.mod.idx[FLAT.idx] <- 0L
      if (BLOCK_OP) {
        BLOCK <- BLOCK + 1L
      }
      FLAT.block[FLAT.idx] <- BLOCK
      BLOCK_OP <- TRUE
      next
    }

    # 3. parse left hand

    # new in 0.6-3
    # first check if all lhs names are valid (in R); see ?make.names
    # and ?reserved
    # for example, 'NA' is a reserved keyword, and should not be used
    # this usually only happens for latent variable names
    #
    # check should not come earlier, as we do not need it for :,==,<,>,:=
    LHS <- strsplit(lhs, split = "+", fixed = TRUE)[[1]]
    # remove modifiers
    LHS <- gsub("^\\S*\\*", "", LHS)
    if (!all(make.names(LHS) == LHS)) {
      lav_msg_stop(gettextf(
        "lavaan ERROR: left hand side (lhs) of this formula: %1$s %2$s %3$s
        contains either a reserved word (in R) or an illegal character: %4$s.
        See ?reserved for a list of reserved words in R. Please use a variable
        name that is not a reserved word in R and use only characters, digits,
        or the dot symbol.",
        lhs, op, rhs, dQuote(LHS[!make.names(LHS) == LHS])
      ))
    }

    lhs.formula <- as.formula(paste("~", lhs))
    lhs.out <- lav_syntax_parse_rhs(rhs = lhs.formula[[2L]], op = op)
    lhs.names <- names(lhs.out)


    # new in 0.6-4
    # handle LHS modifiers (if any)
    # if(sum(sapply(lhs.out, length)) > 0L) {
    # warning("lavaan WARNING: left-hand side of formula below contains modifier:\n", x,"\n")
    # }

    # 4. lav_syntax_parse_rhs (as rhs of a single-sided formula)

    # new 0.5-12: before we do this, replace '0.2?' by 'start(0.2)*'
    # requested by the simsem folks
    rhs <- gsub("\\(?([-]?[0-9]*\\.?[0-9]*)\\)?\\?", "start(\\1)\\*", rhs)




    # new in 0.6-6, check for rhs NAMES that are reserved names
    # like in foo =~ in + out
    RHS <- strsplit(rhs, split = "+", fixed = TRUE)[[1]]
    RHS.names <- gsub("^\\S*\\*", "", RHS)
    BAD <- c("if", "else", "repeat", "while", "function", "for", "in")
    if (any(RHS.names %in% c(BAD, "NA"))) { # "NA" added in 0.6-8
      lav_msg_stop(gettextf(
        "lavaan ERROR: right hand side (rhs) of this formula:\n    ",
        lhs, " ", op, " ", rhs,
        "\n    contains either a reserved word (in R) or an illegal character: ",
        dQuote(RHS.names[which(RHS.names %in% BAD)[1]]),
        "\n    See ?reserved for a list of reserved words in R",
        "\n    Please use a variable name that is not a reserved word in R",
        "\n    and use only characters, digits, or the dot symbol."
      ))
    }
    # new in 0.6-6, check for rhs LABELS that are reserved names
    # like in foo =~ in*bar
    RHS <- strsplit(rhs, split = "+", fixed = TRUE)[[1]]
    RHS.labels <- gsub("\\*\\S*$", "", RHS)
    if (any(RHS.labels %in% BAD)) {
      lav_msg_stop(gettextf(
        "lavaan ERROR: right hand side (rhs) of this formula:\n    ",
        lhs, " ", op, " ", rhs,
        "\n    contains either a reserved word (in R) or an illegal character: ",
        dQuote(RHS.names[which(RHS.labels %in% BAD)[1]]),
        "\n    See ?reserved for a list of reserved words in R",
        "\n    Please use a variable name that is not a reserved word in R",
        "\n    and use only characters, digits, or the dot symbol."
      ))
    }
    # new in 0.6-12: check for three-way interaction terms (which we do
    # NOT support)
    if (any(grepl(":", RHS.names))) {
      ncolon <- sapply(gregexpr(":", RHS.names), length)
      if (any(ncolon > 1L)) {
        idx <- which(ncolon > 1L)
        lav_msg_stop(gettext(
        "Three-way or higher-order interaction terms (using
multiple colons) are not supported in the lavaan syntax; please manually
construct the product terms yourself in the data.frame, give them an
appropriate name, and then you can use these interaction variables as any
other (observed) variable in the model syntax. Problematic term is: "),
          RHS.names[idx[1]]
        )
      }
    }


    rhs.formula <- as.formula(paste("~", rhs))
    out <- lav_syntax_parse_rhs(rhs = rhs.formula[[2L]], op = op)

    if (lav_debug()) print(out)

    # for each lhs element
    for (l in seq_along(lhs.names)) {
      # for each rhs element
      for (j in seq_along(out)) {
        # catch intercepts
        if (names(out)[j] == "intercept") {
          if (op == "~") {
            rhs.name <- ""
          } else {
            # either number (1), or reserved name?
            lav_msg_stop(gettextf("lavaan ERROR: right-hand side of
             formula contains an invalid variable name:\n    %s", x))
          }
        } else if (names(out)[j] == "..zero.." && op == "~") {
          rhs.name <- ""
        } else if (names(out)[j] == "..constant.." && op == "~") {
          rhs.name <- ""
        } else {
          rhs.name <- names(out)[j]
        }

        # move this 'check' to post-parse
        # if(op == "|") {
        #    th.name <- paste("t", j, sep="")
        #    if(names(out)[j] != th.name) {
        #        stop("lavaan ERROR: threshold ", j, " of variable ",
        #             sQuote(lhs.names[1]), " should be named ",
        #             sQuote(th.name), "; found ",
        #             sQuote(names(out)[j]), "\n")
        #    }
        # }

        # catch lhs = rhs and op = "=~"
        if (op == "=~" && lhs.names[l] == names(out)[j]) {
          lav_msg_stop(gettextf("lavaan ERROR: latent variable `", lhs.names[l], "' can not be measured by itself"))
        }

        # check if we not already have this combination (in this group)
        # 1. asymmetric (=~, ~, ~1)
        if (op != "~~") {
          idx <- which(FLAT.lhs == lhs.names[l] &
            FLAT.op == op &
            FLAT.block == BLOCK &
            FLAT.rhs == rhs.name)
          if (length(idx) > 0L) {
            lav_msg_stop(gettextf("lavaan ERROR: duplicate model element in: ", model[i]))
          }
        } else {
          # 2. symmetric (~~)
          idx <- which(FLAT.lhs == rhs.name &
            FLAT.op == "~~" &
            FLAT.block == BLOCK &
            FLAT.rhs == lhs.names[l])
          if (length(idx) > 0L) {
            lav_msg_stop(gettextf("lavaan ERROR: duplicate model element in: ", model[i]))
          }
        }

        # check if we have a self-loop (y ~ y)
        if (op %in% c("~", "<~") && rhs.name == lhs.names[l]) {
          # stop("lavaan ERROR: lhs and rhs are the same in: ",
          #     model[i])
          # this breaks pompom package, example uSEM
          lav_msg_warn(gettextf(
            "lavaan WARNING: lhs and rhs are the same in: ",
            model[i]
          ))
        }


        FLAT.idx <- FLAT.idx + 1L
        FLAT.lhs[FLAT.idx] <- lhs.names[l]
        FLAT.op[FLAT.idx] <- op
        FLAT.rhs[FLAT.idx] <- rhs.name
        FLAT.block[FLAT.idx] <- BLOCK
        FLAT.fixed[FLAT.idx] <- ""
        FLAT.start[FLAT.idx] <- ""
        FLAT.label[FLAT.idx] <- ""
        FLAT.lower[FLAT.idx] <- ""
        FLAT.upper[FLAT.idx] <- ""
        FLAT.prior[FLAT.idx] <- ""
        FLAT.efa[FLAT.idx] <- ""
        FLAT.rv[FLAT.idx] <- ""

        mod <- list()
        rhs.mod <- 0L
        if (length(lhs.out[[l]]$efa) > 0L) {
          mod$efa <- lhs.out[[l]]$efa
          FLAT.efa[FLAT.idx] <- paste(mod$efa, collapse = ";")
          rhs.mod <- 1L # despite being a LHS modifier
        }
        if (length(out[[j]]$fixed) > 0L) {
          mod$fixed <- out[[j]]$fixed
          FLAT.fixed[FLAT.idx] <- paste(mod$fixed, collapse = ";")
          rhs.mod <- 1L
        }
        if (length(out[[j]]$start) > 0L) {
          mod$start <- out[[j]]$start
          FLAT.start[FLAT.idx] <- paste(mod$start, collapse = ";")
          rhs.mod <- 1L
        }
        if (length(out[[j]]$lower) > 0L) {
          mod$lower <- out[[j]]$lower
          FLAT.lower[FLAT.idx] <- paste(mod$lower, collapse = ";")
          rhs.mod <- 1L
        }
        if (length(out[[j]]$upper) > 0L) {
          mod$upper <- out[[j]]$upper
          FLAT.upper[FLAT.idx] <- paste(mod$upper, collapse = ";")
          rhs.mod <- 1L
        }
        if (length(out[[j]]$label) > 0L) {
          mod$label <- out[[j]]$label
          FLAT.label[FLAT.idx] <- paste(mod$label, collapse = ";")
          rhs.mod <- 1L
        }
        if (length(out[[j]]$rv) > 0L) {
          mod$rv <- out[[j]]$rv
          FLAT.rv[FLAT.idx] <- paste(mod$rv, collapse = ";")
          rhs.mod <- 1L
        }
        if (length(out[[j]]$prior) > 0L) {
          mod$prior <- out[[j]]$prior
          FLAT.prior[FLAT.idx] <- paste(mod$prior, collapse = ";")
          rhs.mod <- 1L
        }
        # if(op == "~1" && rhs == "0") {
        #    mod$fixed <- 0
        #    FLAT.fixed[FLAT.idx] <- paste(mod$fixed, collapse=";")
        #    rhs.mod <- 1L
        # }
        if (op == "=~" && rhs == "0") {
          mod$fixed <- 0
          FLAT.rhs[FLAT.idx] <- FLAT.lhs[FLAT.idx]
          FLAT.fixed[FLAT.idx] <- paste(mod$fixed, collapse = ";")
          rhs.mod <- 1L
        }

        FLAT.rhs.mod.idx[FLAT.idx] <- rhs.mod

        if (rhs.mod > 0L) {
          MOD.idx <- MOD.idx + 1L
          MOD[[MOD.idx]] <- mod
        }
      } # rhs elements
    } # lhs elements
  } # model elements

  # enumerate modifier indices
  mod.idx <- which(FLAT.rhs.mod.idx > 0L)
  FLAT.rhs.mod.idx[mod.idx] <- seq_along(mod.idx)

  FLAT <- list(
    lhs = FLAT.lhs, op = FLAT.op, rhs = FLAT.rhs,
    mod.idx = FLAT.rhs.mod.idx, block = FLAT.block,
    fixed = FLAT.fixed, start = FLAT.start,
    lower = FLAT.lower, upper = FLAT.upper,
    label = FLAT.label, prior = FLAT.prior,
    efa = FLAT.efa, rv = FLAT.rv
  )

  # change op for intercepts (for convenience only)
  int.idx <- which(FLAT$op == "~" & FLAT$rhs == "")
  if (length(int.idx) > 0L) {
    FLAT$op[int.idx] <- "~1"
  }

  # new in 0.6, reorder covariances here!
  FLAT <- lav_partable_covariance_reorder(FLAT)

  if (as.data.frame.) {
    FLAT <- as.data.frame(FLAT, stringsAsFactors = FALSE)
  }

  # new in 0.6-4: check for 'group' within 'level'
  if (any(FLAT$op == ":")) {
    op.idx <- which(FLAT$op == ":")
    if (length(op.idx) < 2L) {
      # only 1 block identifier? this is weird -> give warning
      lav_msg_warn(gettextf("lavaan WARNING: syntax contains only a single block identifier: ", FLAT$lhs[op.idx]))
    } else {
      first.block <- FLAT$lhs[op.idx[1L]]
      second.block <- FLAT$lhs[op.idx[2L]]
      if (first.block == "level" &&
        second.block == "group") {
        lav_msg_stop(gettextf("lavaan ERROR: groups can not be nested within levels"))
      }
    }
  }

  attr(FLAT, "modifiers") <- MOD
  attr(FLAT, "constraints") <- CON

  FLAT
}

lav_syntax_parse_rhs <- function(rhs, op = "") {
  # new version YR 15 dec 2011!
  # - no 'equal' field anymore (only labels!)
  # - every modifier is evaluated
  # - unquoted labels are allowed (eg. x1 + x2 + c(v1,v2,v3)*x3)

  # fill in rhs list
  out <- list()
  repeat {
    if (length(rhs) == 1L) { # last one and only a single element
      out <- c(vector("list", 1L), out)
      NAME <- all.vars(rhs)
      if (length(NAME) > 0L) {
        names(out)[1L] <- NAME
      } else { # intercept or zero?
        if (as.character(rhs) == "1") {
          names(out)[1L] <- "intercept"
        } else if (as.character(rhs) == "0") {
          names(out)[1L] <- "..zero.."
          out[[1L]]$fixed <- 0
        } else {
          names(out)[1L] <- "..constant.."
          out[[1L]]$fixed <- 0
        }
      }
      break
    } else if (rhs[[1L]] == "*") { # last one, but with modifier
      out <- c(vector("list", 1L), out)
      NAME <- all.vars(rhs[[3L]])

      if (length(NAME) > 0L) { # not an intercept
        # catch interaction term
        rhs3.names <- all.names(rhs[[3L]])
        if (rhs3.names[1L] == ":") {
          if (length(NAME) == 1) {
            NAME <- paste(NAME[1L], ":", NAME[1L], sep = "")
          } else {
            NAME <- paste(NAME[1L], ":", NAME[2L], sep = "")
          }
        }
        names(out)[1L] <- NAME
      } else { # intercept
        names(out)[1L] <- "intercept"
      }
      i.var <- all.vars(rhs[[2L]], unique = FALSE)
      if (length(i.var) > 0L) {
        # modifier are unquoted labels
        out[[1L]]$label <- i.var
      } else {
        # modifer is something else
        out[[1L]] <- lav_syntax_get_modifier(rhs[[2L]])
      }
      break
    } else if (rhs[[1L]] == ":") { # last one, but interaction term
      out <- c(vector("list", 1L), out)
      NAME <- all.vars(rhs)
      if (length(NAME) == 1) {
        NAME <- paste(NAME[1L], ":", NAME[1L], sep = "")
      } else {
        NAME <- paste(NAME[1L], ":", NAME[2L], sep = "")
      }
      names(out)[1L] <- NAME
      break
    } else if (rhs[[1L]] == "+") { # not last one!

      # three possibilities:
      # 1. length(rhs[[3]] == 3), and rhs[[3L]][[1]] == "*" -> modifier
      # 2. length(rhs[[3]] == 3), and rhs[[3L]][[1]] == ":" -> interaction
      # 3. length(rhs[[3]] == 1) -> single element

      out <- c(vector("list", 1L), out)

      # modifier or not?
      if (length(rhs[[3L]]) == 3L && rhs[[3L]][[1]] == "*") {
        # modifier!!
        NAME <- all.vars(rhs[[3L]][[3]])

        if (length(NAME) > 0L) { # not an intercept
          # catch interaction term
          rhs3.names <- all.names(rhs[[3L]][[3]])
          if (rhs3.names[1L] == ":") {
            if (length(NAME) == 1) {
              NAME <- paste(NAME[1L], ":", NAME[1L], sep = "")
            } else {
              NAME <- paste(NAME[1L], ":", NAME[2L], sep = "")
            }
          }
          names(out)[1L] <- NAME
        } else { # intercept
          names(out)[1L] <- "intercept"
        }
        i.var <- all.vars(rhs[[3]][[2L]], unique = FALSE)
        if (length(i.var) > 0L) {
          # modifier are unquoted labels
          out[[1L]]$label <- i.var
        } else {
          # modifer is something else
          out[[1L]] <- lav_syntax_get_modifier(rhs[[3]][[2L]])
        }

        # interaction term?
      } else if (length(rhs[[3L]]) == 3L && rhs[[3L]][[1]] == ":") {
        # interaction term, without modifier
        NAME <- all.vars(rhs[[3L]])
        if (length(NAME) == 1) {
          NAME <- paste(NAME[1L], ":", NAME[1L], sep = "")
        } else {
          NAME <- paste(NAME[1L], ":", NAME[2L], sep = "")
        }
        names(out)[1L] <- NAME
      } else { # no modifier!!
        NAME <- all.vars(rhs[[3]])
        if (length(NAME) > 0L) {
          names(out)[1L] <- NAME
        } else { # intercept or zero?
          if (as.character(rhs[[3]]) == "1") {
            names(out)[1L] <- "intercept"
          } else if (as.character(rhs[[3]]) == "0") {
            names(out)[1L] <- "..zero.."
            out[[1L]]$fixed <- 0
          } else {
            names(out)[1L] <- "..constant.."
            out[[1L]]$fixed <- 0
          }
        }
      }


      # next element
      rhs <- rhs[[2L]]
    } else {
      lav_msg_stop(gettextf("lavaan ERROR: I'm confused parsing this line: ", rhs, "\n"))
    }
  }

  # if multiple elements, check for duplicated elements and merge if found
  if (length(out) > 1L) {
    rhs.names <- names(out)
    while (!is.na(idx <- which(duplicated(rhs.names))[1L])) {
      dup.name <- rhs.names[idx]
      orig.idx <- match(dup.name, rhs.names)
      merged <- c(out[[orig.idx]], out[[idx]])
      if (!is.null(merged)) { # be careful, NULL will delete element
        out[[orig.idx]] <- merged
      }
      out <- out[-idx]
      rhs.names <- names(out)
    }
  }

  # if thresholds, check order and reorder if necessary
  # if(op == "|") {
  #    t.names <- names(out)
  #    idx <- match(sort(t.names), t.names)
  #    out <- out[idx]
  # }

  out
}


lav_syntax_get_modifier <- function(mod) {
  if (length(mod) == 1L) {
    # three possibilites: 1) numeric, 2) NA, or 3) quoted character
    if (is.numeric(mod)) {
      return(list(fixed = mod))
    }
    if (is.na(mod)) {
      return(list(fixed = as.numeric(NA)))
    }
    if (is.character(mod)) {
      return(list(label = mod))
    }
  } else if (mod[[1L]] == "start") {
    cof <- unlist(lapply(as.list(mod)[-1],
      eval,
      envir = NULL, enclos = NULL
    ))
    return(list(start = cof))
  } else if (mod[[1L]] == "lower") {
    cof <- unlist(lapply(as.list(mod)[-1],
      eval,
      envir = NULL, enclos = NULL
    ))
    return(list(lower = cof))
  } else if (mod[[1L]] == "upper") {
    cof <- unlist(lapply(as.list(mod)[-1],
      eval,
      envir = NULL, enclos = NULL
    ))
    return(list(upper = cof))
  } else if (mod[[1L]] == "equal") {
    label <- unlist(lapply(as.list(mod)[-1],
      eval,
      envir = NULL, enclos = NULL
    ))
    return(list(label = label))
  } else if (mod[[1L]] == "label") {
    label <- unlist(lapply(as.list(mod)[-1],
      eval,
      envir = NULL, enclos = NULL
    ))
    label[is.na(label)] <- "" # catch 'NA' elements in a label
    return(list(label = label))
  } else if (mod[[1L]] == "rv") {
    rv <- unlist(lapply(as.list(mod)[-1],
      eval,
      envir = NULL, enclos = NULL
    ))
    if (anyNA(rv)) {
      lav_msg_stop(gettextf("lavaan ERROR: some rv() labels are NA"))
    }
    return(list(rv = rv))
  } else if (mod[[1L]] == "prior") {
    prior <- unlist(lapply(as.list(mod)[-1],
      eval,
      envir = NULL, enclos = NULL
    ))
    return(list(prior = prior))
  } else if (mod[[1L]] == "efa") {
    efa <- unlist(lapply(as.list(mod)[-1],
      eval,
      envir = NULL, enclos = NULL
    ))
    return(list(efa = efa))
  } else if (mod[[1L]] == "c") {
    # vector: we allow numeric and character only!
    cof <- unlist(lapply(as.list(mod)[-1],
      eval,
      envir = NULL, enclos = NULL
    ))
    if (all(is.na(cof))) {
      return(list(fixed = rep(as.numeric(NA), length(cof))))
    } else if (is.numeric(cof)) {
      return(list(fixed = cof))
    } else if (is.character(cof)) {
      cof[is.na(cof)] <- "" # catch 'NA' elements in a label
      return(list(label = cof))
    } else {
      lav_msg_stop(gettextf("lavaan ERROR: can not parse modifier:", mod, "\n"))
    }
  } else {
    # unknown expression
    # as a final attempt, we will evaluate it and coerce it
    # to either a numeric or character (vector)
    cof <- try(eval(mod, envir = NULL, enclos = NULL), silent = TRUE)
    if (inherits(cof, "try-error")) {
      lav_msg_stop(gettextf(
        "lavaan ERROR: evaluating modifier failed: ",
        paste(as.character(mod)[[1]], "()*", sep = ""), "\n"
      ))
    } else if (is.numeric(cof)) {
      return(list(fixed = cof))
    } else if (is.character(cof)) {
      return(list(label = cof))
    } else {
      lav_msg_stop(gettextf(
        "lavaan ERROR: can not parse modifier: ",
        paste(as.character(mod)[[1]], "()*", sep = ""), "\n"
      ))
    }
  }
}

# check if the partable is complete/consistent
# we may have added intercepts/variances (user = 0), fixed to zero
lav_partable_check <- function(partable, categorical = FALSE) {
  check <- TRUE

  # check for empy table - or should we WARN?
  if (length(partable$lhs) == 0) {
    return(check)
  }

  # get observed/latent variables
  ov.names <- lav_partable_vnames(partable, "ov.nox") # no need to specify exo??
  lv.names <- lav_partable_vnames(partable, "lv")
  lv.names.c <- lav_partable_vnames(partable, "lv.composite")
  lv.names.noc <- lv.names[!lv.names %in% lv.names.c]
  all.names <- c(ov.names, lv.names.noc)
  ov.names.ord <- lav_partable_vnames(partable, "ov.ord")

  nlevels <- lav_partable_nlevels(partable)

  # if categorical, we should have some ov.names.ord
  if (categorical && length(ov.names.ord) == 0L) {
    check <- FALSE
    lav_msg_warn(gettext("parameter table does not contain thresholds"))
  }

  # we should have a (residual) variance for *each* ov/lv
  # note: if lav_model_partable() has been used, this is always TRUE
  var.idx <- which(partable$op == "~~" &
    partable$lhs == partable$rhs & !partable$lhs %in% lv.names.c)
  missing.idx <- which(is.na(match(all.names, partable$lhs[var.idx])))
  if (length(missing.idx) > 0L) {
    check <- FALSE
    lav_msg_warn(gettextf(
      "parameter table does not contain (residual) variances for
      one or more variables: %s",
      lav_msg_view(all.names[missing.idx])))
  }

  # meanstructure?
  meanstructure <- any(partable$op == "~1")

  # if meanstructure, check for missing intercepts
  # note if lav_model_partable() has been used, this is always TRUE
  if (meanstructure) {
    # we should have a intercept for *each* ov/lv
    int.idx <- which(partable$op == "~1")
    missing.idx <- which(is.na(match(all.names, partable$lhs[int.idx])))
    if (length(missing.idx) > 0L) {
      check <- FALSE
      lav_msg_warn(gettextf(
        "parameter table does not contain intercepts
        for one or more variables: %s",
        lav_msg_view(all.names[missing.idx])))
    }
  }

  # ok, now the 'real' checks

  # do we have added (residual) variances (user = 0) that are fixed to zero?
  # this is not necessarily problematic!
  # eg. in latent change score models
  # therefore, we do NOT give a warning

  # var.fixed <- which(partable$op == "~~" &
  #                   partable$lhs == partable$rhs &
  #                   partable$user == 0 &
  #                   partable$free == 0)
  # if(length(var.fixed) > 0L) {
  #    check <- FALSE
  #     if(warn) {
  #        warning("lavaan WARNING: missing (residual) variances are set to",
  #        " zero: [", paste(partable$lhs[var.fixed],  collapse = " "), "]")
  #    }
  # }

  # do we have added intercepts (user = 0) that are fixed to zero?
  # this is not necessarily problematic; perhaps only for
  # exogenous variables?
  ov.ind <- unique(partable$rhs[partable$op == "=~"])
  lv.names <- unique(partable$lhs[partable$op == "=~"])
  int.fixed <- which(partable$op == "~1" &
    partable$user == 0L &
    partable$free == 0L &
    partable$ustart == 0L &
    # ignore block/group 1 -- typically within level exo
    !(partable$block %% nlevels == 1L) &
    # do not include factors
    !partable$lhs %in% lv.names &
    # do not include ordered variables
    !partable$lhs %in% ov.names.ord &
    # do not include indicators
    !partable$lhs %in% ov.ind)

  if (length(int.fixed) > 0L) {
    check <- FALSE
    lav_msg_warn(gettext("automatically added intercepts are set to zero:"),
                 lav_msg_view(partable$lhs[int.fixed]))
  }

  # return check code
  check
}

# special functions for the one-factor model
# YR 24 June 2018

# 1-factor model with (only) three indicators:
# no iterations needed; can be solved analytically

# denote s11, s22, s33 the diagonal elements, and
# s21, s31, s32 the off-diagonal elements

# under the 1-factor model; typically, either psi == 1, or l1 == 1
# - s11 == l1^2*psi + theta1
# - s22 == l2^2*psi + theta2
# - s33 == l3^2*psi + theta3
# - s21 == l2*l1*psi
# - s31 == l3*l1*psi
# - s32 == l3*l2*psi
# 6 unknowns, 6 knowns

# note: if the triad of covariances is negative, there is no
# `valid' solution, for example:
#
# > S
#      [,1] [,2] [,3]
# [1,]  1.0  0.6  0.3
# [2,]  0.6  1.0 -0.1
# [3,]  0.3 -0.1  1.0
#
# (note: all eigenvalues are positive)

lav_cfa_1fac_3ind <- function(sample.cov, std.lv = FALSE,
                              warn.neg.triad = TRUE, bounds = TRUE) {
  # check sample cov
  stopifnot(is.matrix(sample.cov))
  nRow <- NROW(sample.cov)
  nCol <- NCOL(sample.cov)
  stopifnot(nRow == nCol, nRow < 4L, nCol < 4L)
  nvar <- nRow

  # we expect a 3x3 sample covariance matrix
  # however, if we get a 2x2 (or 1x1 covariance matrix), do something
  # useful anyways...
  if (nvar == 1L) {
    # lambda = 1, theta = 0, psi = sample.cov[1,1]
    # lambda = 1, theta = 0, psi = 1 (for now, until NlsyLinks is fixed)
    sample.cov <- matrix(1, 3L, 3L) * 1.0
  } else if (nvar == 2L) {
    # hm, we could force both lambda's to be 1, but if the second
    # one is negative, this will surely lead to non-convergence issues
    #
    # just like lavaan < 0.6.2, we will use the regression of y=marker
    # on x=item2
    mean.2var <- mean(diag(sample.cov))
    max.var <- max(diag(sample.cov))
    extra <- c(mean.2var, sample.cov[2, 1])
    sample.cov <- rbind(cbind(sample.cov, extra, deparse.level = 0),
      c(extra, max.var),
      deparse.level = 0
    )
  }

  s11 <- sample.cov[1, 1]
  s22 <- sample.cov[2, 2]
  s33 <- sample.cov[3, 3]
  stopifnot(s11 > 0, s22 > 0, s33 > 0)

  s21 <- sample.cov[2, 1]
  s31 <- sample.cov[3, 1]
  s32 <- sample.cov[3, 2]
  # note: s21*s31*s32 should be positive!
  neg.triad <- FALSE
  if (s21 * s31 * s32 < 0) {
    neg.triad <- TRUE
    if (warn.neg.triad) {
      lav_msg_warn(gettext("product of the three covariances is negative!"))
    }
  }

  # first, we assume l1 = 1
  psi <- (s21 * s31) / s32 # note that we assume |s32|>0
  l1 <- 1
  l2 <- s32 / s31 # l2 <- s21/psi
  l3 <- s32 / s21 # l3 <- s31/psi
  theta1 <- s11 - psi
  theta2 <- s22 - l2 * l2 * psi
  theta3 <- s33 - l3 * l3 * psi

  # sanity check (new in 0.6-11): apply standard bounds
  if (bounds) {
    lower.psi <- s11 - (1 - 0.1) * s11 # we assume REL(y1) >= 0.1
    psi <- min(max(psi, lower.psi), s11)

    l2.bound <- sqrt(s22 / lower.psi)
    l2 <- min(max(-l2.bound, l2), l2.bound)
    l3.bound <- sqrt(s33 / lower.psi)
    l3 <- min(max(-l3.bound, l3), l3.bound)

    theta1 <- min(max(theta1, 0), s11)
    theta2 <- min(max(theta2, 0), s22)
    theta3 <- min(max(theta3, 0), s33)
  }

  lambda <- c(l1, l2, l3)
  theta <- c(theta1, theta2, theta3)


  # std.lv?
  if (std.lv) {
    # we allow for negative psi (if bounds = FALSE)
    lambda <- lambda * sign(psi) * sqrt(abs(psi))
    psi <- 1
  }

  # special cases
  if (nvar == 1L) {
    lambda <- lambda[1]
    theta <- theta[1]
  } else if (nvar == 2L) {
    lambda <- lambda[1:2]
    theta <- theta[1:2]
    psi <- psi / 2 # smaller works better?
  }

  list(lambda = lambda, theta = theta, psi = psi, neg.triad = neg.triad)
}

# FABIN (Hagglund, 1982)
# 1-factor only
lav_cfa_1fac_fabin <- function(S, lambda.only = FALSE, method = "fabin3",
                               std.lv = FALSE, bounds = TRUE) {
  # check arguments
  if (std.lv) {
    lambda.only <- FALSE # we need psi
  }

  nvar <- NCOL(S)

  # catch nvar < 4
  if (nvar < 4L) {
    out <- lav_cfa_1fac_3ind(
      sample.cov = S, std.lv = std.lv,
      warn.neg.triad = FALSE
    )
    return(out)
  }

  # 1. lambda
  lambda <- numeric(nvar)
  lambda[1L] <- 1.0
  for (i in 2:nvar) {
    idx3 <- (1:nvar)[-c(i, 1L)]
    s23 <- S[i, idx3]
    S31 <- S13 <- S[idx3, 1L]
    if (method == "fabin3") {
      S33 <- S[idx3, idx3]
      tmp <- try(solve(S33, S31), silent = TRUE) # GaussJordanPivot is
      # slighty more efficient
      if (inherits(tmp, "try-error")) {
        lambda[i] <- sum(s23 * S31) / sum(S13^2)
      } else {
        lambda[i] <- sum(s23 * tmp) / sum(S13 * tmp)
      }
    } else {
      lambda[i] <- sum(s23 * S31) / sum(S13^2)
    }
  }

  # bounds? (new in 0.6-11)
  if (bounds) {
    s11 <- S[1, 1]
    lower.psi <- s11 - (1 - 0.1) * s11 # we assume REL(y1) >= 0.1
    for (i in 2:nvar) {
      l.bound <- sqrt(S[i, i] / lower.psi)
      lambda[i] <- min(max(-l.bound, lambda[i]), l.bound)
    }
  }

  if (lambda.only) {
    return(list(
      lambda = lambda, psi = as.numeric(NA),
      theta = rep(as.numeric(NA), nvar)
    ))
  }

  # 2. theta

  # GLS version
  # W <- solve(S)
  # LAMBDA <- as.matrix(lambda)
  # A1 <- solve(t(LAMBDA) %*% W %*% LAMBDA) %*% t(LAMBDA) %*% W
  # A2 <- W %*% LAMBDA %*% A1

  # tmp1 <- W*W - A2*A2
  # tmp2 <- diag( W %*% S %*% W - A2 %*% S %*% A2 )
  # theta.diag <- solve(tmp1, tmp2)

  # 'least squares' version, assuming W = I
  D <- tcrossprod(lambda) / sum(lambda^2)
  theta <- solve(diag(nvar) - D * D, diag(S - (D %*% S %*% D)))

  # 3. psi (W=I)
  S1 <- S - diag(theta)
  l2 <- sum(lambda^2)
  psi <- sum(colSums(as.numeric(lambda) * S1) * lambda) / (l2 * l2)

  # std.lv?
  if (std.lv) {
    # we allow for negative psi
    lambda <- lambda * sign(psi) * sqrt(abs(psi))
    psi <- 1
  }

  list(lambda = lambda, theta = theta, psi = psi)
}

## STEP 1b: compute Var(eta) and E(eta) per block
##          only needed for local/fsr approach!
lav_sam_step1_local <- function(STEP1 = NULL, FIT = NULL, Y = NULL,
                                sam.method = "local",
                                local.options = list(
                                  M.method = "ML",
                                  lambda.correction = TRUE,
                                  alpha.correction = 0L,
                                  twolevel.method = "h1"
                                ),
                                return.cov.iveta2 = TRUE,
                                return.FS = FALSE) {
  # local.M.method
  local.M.method <- toupper(local.options[["M.method"]])
  if (!local.M.method %in% c("GLS", "ML", "ULS")) {
    lav_msg_stop(gettext(
      "local option M.method should be one of ML, GLS or ULS."))
  }

  lavoptions <- FIT@Options
  lavpta <- FIT@pta
  nblocks <- lavpta$nblocks

  # flags
  lv.interaction.flag <- FALSE
  lv.higherorder.flag <- FALSE
  if (length(unlist(lavpta$vnames$lv.interaction)) > 0L) {
    lv.interaction.flag <- TRUE
  }
  if (length(unlist(lavpta$vnames$lv.ind)) > 0L) {
    lv.higherorder.flag <- TRUE
  }

  if (lav_verbose()) {
    cat("Constructing the mapping matrix using the ",
      local.M.method, " method ... ",
      sep = ""
    )
  }

  # all the measurement parameters are already stored in PT
  PT <- STEP1$PT
  if (FIT@Model@ceq.simple.only) {
    x.free <- PT$est[PT$free > 0 & !duplicated(PT$free)]
  } else {
    x.free <- PT$est[PT$free > 0]
  }
  # check for NA values (eg in BETA); set them to zero
  x.free[!is.finite(x.free)] <- 0

  lavmodel.tmp <- lav_model_set_parameters(FIT@Model, x = x.free)
  LAMBDA <- THETA <- BETA <- PSI <- NU <- DELTA <- NULL

  # create LAMBDA
  lambda.idx <- which(names(FIT@Model@GLIST) == "lambda")
  LAMBDA <- lavmodel.tmp@GLIST[lambda.idx]

  # create THETA
  theta.idx <- which(names(FIT@Model@GLIST) == "theta")
  THETA <- lavmodel.tmp@GLIST[theta.idx]

  # NU
  if (FIT@Model@meanstructure) {
    nu.idx <- which(names(FIT@Model@GLIST) == "nu")
    NU <- lavmodel.tmp@GLIST[nu.idx]
  }

  # DELTA
  if (FIT@Model@categorical || FIT@Model@correlation) {
    delta.idx <- which(names(FIT@Model@GLIST) == "delta")
    DELTA <- lavmodel.tmp@GLIST[delta.idx]
  }

  # BETA/PSI
  if (lv.higherorder.flag) {
    beta.idx <- which(names(FIT@Model@GLIST) == "beta")
    BETA <- lavmodel.tmp@GLIST[beta.idx]
    psi.idx <- which(names(FIT@Model@GLIST) == "psi")
    PSI <- lavmodel.tmp@GLIST[psi.idx]
  }

  # GAMMA (only for names, if conditional.x)
  #if (FIT@Model@conditional.x) {
  #  gamma.idx <- which(names(FIT@Model@GLIST) == "gamma")
  #}

  # handle dummy's + higher-order + rank-deficient
  lsam.analytic.flag <- rep(TRUE, nblocks)
  L.veta <- vector("list", length = nblocks)
  for (b in seq_len(nblocks)) {
    # new in 0.6-10: check if any indicators are also involved
    # in the structural part; if so, set THETA row/col to zero
    # and make sure LAMBDA element is correctly set
    # (we also need to adjust M)
    dummy.ov.idx <- FIT@Model@ov.y.dummy.ov.idx[[b]]
    dummy.lv.idx <- FIT@Model@ov.y.dummy.lv.idx[[b]]
    if (length(dummy.ov.idx)) {
      THETA[[b]][dummy.ov.idx, ] <- 0
      THETA[[b]][, dummy.ov.idx] <- 0
      LAMBDA[[b]][dummy.ov.idx, ] <- 0
      LAMBDA[[b]][cbind(dummy.ov.idx, dummy.lv.idx)] <- 1
    }
    if (FIT@Model@meanstructure) {
      if (length(dummy.ov.idx)) {
        NU[[b]][dummy.ov.idx, 1] <- 0
      }
    }

    # get ALL lv names (including dummy ov.x/ov.y)
    lv.names <- FIT@Model@dimNames[[lambda.idx[b]]][[2L]]

    # if conditional.x, we must add the ov.names.x manually
    # if (FIT@Model@conditional.x) {
    #   exo.names <- FIT@Model@dimNames[[gamma.idx[b]]][[2L]]
    #   lv.names <- c(lv.names, exo.names)
    # }

    # handle higher-order factors here
    if (length(lavpta$vidx$lv.ind[[b]]) > 0L) {
      lv.ind.names <- lavpta$vnames$lv.ind[[b]]
      lv.target <- lv.names[!lv.names %in% lv.ind.names]

      target.idx <- match(lv.target, lv.names)
      other.idx <- seq_len(length(lv.names))[-target.idx]

      this.beta <- BETA[[b]]
      this.beta[is.na(this.beta)] <- 0

      IB <- diag(nrow(this.beta)) - this.beta
      IB.inv <- solve(IB)
      LB.inv <- LAMBDA[[b]] %*% IB.inv

      # replace LAMBDA
      LAMBDA[[b]] <- LB.inv[,target.idx,drop = FALSE]

      PSI.other <- PSI[[b]][other.idx, other.idx, drop = FALSE]
      LB.inv2 <- LB.inv[, other.idx, drop = FALSE]

      # replace THETA
      THETA[[b]] <- LB.inv2 %*% PSI.other %*% t(LB.inv2) + THETA[[b]]
    }

    # check if LAMBDA has full column rank
    this.lambda <- LAMBDA[[b]]
    if (length(lavpta$vidx$lv.interaction[[b]]) > 0L) {
      if (length(lavpta$vidx$lv.ind[[b]]) > 0L) {
        rm.idx <- c(match(lavpta$vnames$lv.ind[[b]], lv.names),
                    match(lavpta$vnames$lv.interaction[[b]], lv.names))
        this.lambda <- this.lambda[, -rm.idx, drop = FALSE]
      } else {
        rm.idx <- match(lavpta$vnames$lv.interaction[[b]], lv.names)
        this.lambda <- this.lambda[, -rm.idx, drop = FALSE]
      }
    }
    if (qr(this.lambda)$rank < ncol(this.lambda)) {
      if (sam.method == "local" && !lv.interaction.flag) {
        lsam.analytic.flag[b] <- FALSE
        # we will try an iterative solution
      } else {
        # eg cfsr or lv interactions: no idea what to do here (yet)
        print(this.lambda)
        lav_msg_stop(gettext(
          "LAMBDA has no full column rank. Please use sam.method = global"))
      }
    }

    # if lambda has full rank, check if cov.lv is unrestricted
    if (!lsam.analytic.flag[b]) {
      VETA.symbolic <- lav_sam_veta_partable(FIT, block = b)
      # this is the tricky thing: which rows/cols should we remove?
      # none for now
      if (FIT@Options$std.lv) {
        veta.symbolic <- lav_matrix_vech(VETA.symbolic, diagonal = FALSE)
      } else {
        veta.symbolic <- lav_matrix_vech(VETA.symbolic, diagonal = TRUE)
      }
      if (any(veta.symbolic == 0)) {
        lsam.analytic.flag[b] <- FALSE
        nfac <- ncol(VETA.symbolic)
        m.free <- which(VETA.symbolic != 0)
        tmp <- lav_matrix_vech_reverse(lav_matrix_vech_idx(nfac))
        x.free <- tmp[which(VETA.symbolic != 0)]
        unique.idx <- unique(x.free)
        row.idx <- match(x.free, unique.idx)
        L.psi <- matrix(0L, nrow = nfac * nfac, ncol = length(unique.idx))
        IDX <- cbind(m.free, row.idx)
        L.psi[IDX] <- 1L
        L.veta[[b]] <- L.psi
      }
    }
  } # b

  # store LAMBDA/THETA/NU per block
  STEP1$LAMBDA <- LAMBDA
  STEP1$THETA <- THETA
  if (FIT@Model@meanstructure) {
    STEP1$NU <- NU
  }
  if (FIT@Model@categorical || FIT@Model@correlation) {
    STEP1$DELTA <- DELTA
  }

  VETA     <- vector("list", nblocks)
  MSM..    <- vector("list", nblocks)
  MTM..    <- vector("list", nblocks)
  FS.mean  <- vector("list", nblocks)
  #FS.gamma <- vector("list", nblocks)
  FS       <- vector("list", nblocks)
  COV.IVETA2 <- vector("list", nblocks)
  REL <- vector("list", nblocks)
  alpha <- vector("list", nblocks)
  lambda <- vector("list", nblocks)
  if (lavoptions$meanstructure) {
    EETA <- vector("list", nblocks)
  } else {
    EETA <- NULL
  }
  #fs.outlier.idx <- vector("list", nblocks)
  M <- vector("list", nblocks)
  LV.NAMES <- vector("list", nblocks)

  # if (lv.interaction.flag && is.null(FS)) {
  #   # compute Bartlett factor scores
  #   FS <- vector("list", nblocks)
  #   # FS.mm <- lapply(STEP1$MM.FIT, lav_predict_eta_bartlett)
  #   FS.mm <- lapply(STEP1$MM.FIT, lavPredict,
  #     method = "Bartlett",
  #     drop.list.single.group = FALSE
  #   )
  #   for (b in seq_len(nblocks)) {
  #     tmp <- lapply(
  #       1:length(STEP1$MM.FIT),
  #       function(x) FS.mm[[x]][[b]]
  #     )
  #     LABEL <- unlist(lapply(tmp, colnames))
  #     FS[[b]] <- do.call("cbind", tmp)
  #     colnames(FS[[b]]) <- LABEL
  #     FS[[b]] <- FIT@Data@X[[b]] %*%

  #     # dummy lv's? (both 'x' and 'y'!)
  #     dummy.ov.idx <- c(FIT@Model@ov.y.dummy.ov.idx[[b]],
  #                       FIT@Model@ov.x.dummy.ov.idx[[b]])
  #     dummy.lv.idx <- c(FIT@Model@ov.y.dummy.lv.idx[[b]],
  #                       FIT@Model@ov.x.dummy.lv.idx[[b]])
  #     if (length(dummy.lv.idx) > 0L) {
  #       FS.obs <- FIT@Data@X[[b]][, dummy.ov.idx, drop = FALSE]
  #       colnames(FS.obs) <- FIT@Data@ov.names[[b]][dummy.ov.idx]
  #       FS[[b]] <- cbind(FS[[b]], FS.obs)
  #     }
  #   }
  # }

  # compute VETA/EETA per block
  for (b in seq_len(nblocks)) {

    # which group is this?
    this.group <- floor(b / FIT@Data@nlevels + 0.5)

    # lv.names, including dummy-lv covariates
    psi.idx <- which(names(FIT@Model@GLIST) == "psi")[b]
    lv.names.b <- FIT@Model@dimNames[[psi.idx]][[1L]] # including dummy/inter.
    # if (FIT@Model@conditional.x) {
    #   exo.names <- FIT@Model@dimNames[[gamma.idx[b]]][[2L]]
    #   lv.names.b <- c(lv.names.b, exo.names)
    # }
    rm.idx <- integer(0L)

    # higher-order? remove lower-order factors
    if (lv.higherorder.flag && length(lavpta$vnames$lv.ind[[b]]) > 0L) {
      rm.idx <- c(rm.idx, match(lavpta$vnames$lv.ind[[b]], lv.names.b))
    }

    # interaction terms? remove them for VETA
    if (lv.interaction.flag && length(lavpta$vnames$lv.interaction[[b]]) > 0L) {
      rm.idx <- c(rm.idx, match(lavpta$vnames$lv.interaction[[b]], lv.names.b))
      lv.int.names <- lavpta$vnames$lv.interaction[[b]]
    }

    # final names for EETA/VETA (not including interaction terms!)
    lv.names1 <- lv.names.b
    if (length(rm.idx) > 0L) {
      lv.names1 <- lv.names.b[-rm.idx]
    }
    LV.NAMES[[b]] <- lv.names1

    # get sample statistics for this block
    COV <- STEP1$COV[[b]]
    YBAR <- drop(STEP1$YBAR[[b]])

    # rescale COV?
    if (FIT@Data@nlevels == 1L &&
        (FIT@Model@categorical || FIT@Model@correlation)) {
      SCALE.vector <- 1 / (drop(DELTA[[b]]))
      COV <- SCALE.vector * COV * rep(SCALE.vector, each = ncol(COV))
      YBAR <- SCALE.vector * YBAR # Checkme!
    }

    # do we need ICOV?
    if (local.M.method == "GLS") {
      if (FIT@Options$sample.cov.rescale) {
        # get unbiased S
        N <- FIT@SampleStats@nobs[[this.group]]
        COV.unbiased <- COV * N / (N - 1)
        ICOV <- solve(COV.unbiased)
      } else {
        ICOV <- solve(COV)
      }
    }

    # compute mapping matrix 'M'
    this.lambda <- LAMBDA[[b]]
    if (length(lavpta$vidx$lv.interaction[[b]]) > 0L) {
      this.lambda <- this.lambda[, -lavpta$vidx$lv.interaction[[b]]]
    }
    if (lsam.analytic.flag[b]) {
      Mb <- lav_sam_mapping_matrix(
        LAMBDA = this.lambda,
        THETA = THETA[[b]],
        S = COV, S.inv = ICOV,
        method = local.M.method
      )
    } else {
      Mb <- matrix(as.numeric(NA), ncol(this.lambda), nrow(this.lambda))
    }
    if (length(lavpta$vidx$lv.interaction[[b]]) > 0L) {
      tmp <- Mb
      Mb <- matrix(0, nrow = ncol(LAMBDA[[b]]), ncol = nrow(LAMBDA[[b]]))
      Mb[-lavpta$vidx$lv.interaction[[b]], ] <- tmp
    }

    # handle observed-only variables (needed?)
    dummy.ov.idx <- c(
      FIT@Model@ov.x.dummy.ov.idx[[b]],
      FIT@Model@ov.y.dummy.ov.idx[[b]]
    )
    dummy.lv.idx <- c(
      FIT@Model@ov.x.dummy.lv.idx[[b]],
      FIT@Model@ov.y.dummy.lv.idx[[b]]
    )

    # handle conditional.x
    # if (FIT@Model@conditional.x) {
    #   I0 <- diag(x = 0, nrow = length(exo.names))
    #   I1 <- diag(x = 1, nrow = length(exo.names))
    #   Mb <- lav_matrix_bdiag(Mb, I1)
    #   LAMBDA[[b]] <- lav_matrix_bdiag(LAMBDA[[b]], I1)
    #   THETA[[b]] <- lav_matrix_bdiag(THETA[[b]], I0)
    #   NU[[b]] <- c(drop(NU[[b]]), numeric(length(exo.names)))
    # }

    # fix dummy.lv.idx if we have higher-order factors!
    if (lv.higherorder.flag) {
      dummy.lv.idx <- match(lv.names.b[dummy.lv.idx], lv.names1)
    }

    if (length(dummy.ov.idx)) {
      Mb[dummy.lv.idx, ] <- 0
      Mb[cbind(dummy.lv.idx, dummy.ov.idx)] <- 1
    }

    # here, we remove the lv.interaction row(s) from Mb
    # FIXME: if we have higher order factors!
    if (length(lavpta$vidx$lv.interaction[[b]]) > 0L) {
      Mb <- Mb[-lavpta$vidx$lv.interaction[[b]], ]
    }

    # compute EETA
    if (lavoptions$meanstructure) {
      if (lsam.analytic.flag[b]) {
        EETA[[b]] <- lav_sam_eeta(M = Mb, YBAR = YBAR, NU = NU[[b]])
      } else {
        # EETA is constrained somehow
        lav_msg_stop(gettext("not ready yet"))
        # EETA[[b]] <- lav_sam_eeta_con(YBAR = YBAR, LAMBDA = LAMBDA[[b]],
        #                               THETA = THETA[[b]],
        #                               L.veta = L.veta[[b]])

      }
	  FS.mean[[b]] <- EETA[[b]] # ok if no interaction
    }

    # compute VETA
    if (sam.method == "local") {
      if (lsam.analytic.flag[b]) {
        tmp <- lav_sam_veta(
          M = Mb, S = COV, THETA = THETA[[b]],
          alpha.correction = local.options[["alpha.correction"]],
          lambda.correction = local.options[["lambda.correction"]],
          N <- FIT@SampleStats@nobs[[this.group]],
          dummy.lv.idx = dummy.lv.idx,
          extra = TRUE
        )
        VETA[[b]] <- tmp[, , drop = FALSE] # drop attributes
        alpha[[b]]  <- attr(tmp, "alpha")
        lambda[[b]] <- attr(tmp, "lambda.star")
	    MSM..[[b]]  <- attr(tmp, "MSM")
	    MTM..[[b]]  <- attr(tmp, "MTM")
      } else {
        # VETA is constrained somehow
        VETA[[b]] <- lav_sam_veta_con(S = COV, LAMBDA = LAMBDA[[b]],
                                      THETA = THETA[[b]], L.veta = L.veta[[b]],
                                      local.M.method = local.M.method)
        alpha[[b]]  <- as.numeric(NA)
        lambda[[b]] <- as.numeric(NA)
        MSM..[[b]]  <- matrix(0, 0, 0)
        MTM..[[b]]  <- matrix(0, 0, 0)
      }
    } else if (sam.method == "cfsr") {
      # first, we need to 'true' VETA (to get Sigma)
      tmp <- lav_sam_veta(
        M = Mb, S = COV, THETA = THETA[[b]],
        alpha.correction = 0L,
        lambda.correction = local.options[["lambda.correction"]],
        N <- FIT@SampleStats@nobs[[this.group]],
        dummy.lv.idx = dummy.lv.idx,
        extra = FALSE
      )
      VETA[[b]] <- tmp[, , drop = FALSE]
      # compute 'Sigma'
      Sigma <- this.lambda %*% VETA[[b]] %*% t(this.lambda) + THETA[[b]]
      tmat <- lav_predict_tmat_det_internal(Sigma = Sigma, Veta = VETA[[b]],
                                            Lambda = this.lambda)
      A <- tmat %*% Mb
      VETA[[b]] <- A %*% COV %*% t(A)
    } else {
      # FSR -- no correction
      VETA[[b]] <- Mb %*% COV %*% t(Mb)
    }

    # standardize? not really needed, but we may have 1.0000001
    # as variances, and this may lead to false convergence
    if (FIT@Options$std.lv) {
      # warning: we should only do this for the LVs, not the
      # observed variables
      if (length(dummy.lv.idx) == 0L) {
        VETA[[b]] <- stats::cov2cor(VETA[[b]])
      } else {
        tmp <- VETA[[b]]
        tmp.lv <- stats::cov2cor(VETA[[b]][-dummy.lv.idx,
                                           -dummy.lv.idx, drop = FALSE])
        VETA[[b]][-dummy.lv.idx, -dummy.lv.idx] <- tmp.lv
      }
    }
    colnames(VETA[[b]]) <- rownames(VETA[[b]]) <- lv.names1

    # compute model-based RELiability
    # REL[[b]] <- diag(VETA[[b]]] %*% solve(MSM..[[b]])) # CHECKme! -> done, must be:
    if (lsam.analytic.flag[b]) {
      REL[[b]] <- diag(VETA[[b]]) / diag(MSM..[[b]]) #!
    } else {
      REL[[b]] <- as.numeric(NA)
    }

    # check for lv.interactions
    if (lv.interaction.flag && length(lv.int.names) > 0L) {
      if (FIT@Model@categorical || FIT@Model@correlation) {
        lav_msg_stop(gettext("SAM + lv interactions do not work (yet) if
                             correlation structures are used."))
      }

      # compute Bartlett factor scores here
      if (is.null(Y)) {
        Yb <- FIT@Data@X[[b]]
      } else {
        Yb <- Y[[b]]
      }
      # center
      Yb.c <- t( t(Yb) - drop(NU[[b]]) )
      FS.b <- Yb.c %*% t(Mb)
      colnames(FS.b) <- lv.names1
      # FIXME: what about observed covariates?

      # get (approximate) indices with outliers
      #fs.outlier.idx[[b]] <- lav_sample_outlier_idx(lav_sample_mdist(FS.b), coef = 1.5)

      # EETA2
      EETA1 <- EETA[[b]]
      EETA[[b]] <- lav_sam_eeta2(
        EETA = EETA1, VETA = VETA[[b]],
        lv.names = lv.names1,
        lv.int.names = lv.int.names
      )

      # VETA2
      if (sam.method == "local") {
        tmp <- lav_sam_veta2(
          FS = FS.b, M = Mb,
          VETA = VETA[[b]], EETA = EETA1,
          THETA = THETA[[b]],
          lv.names = lv.names1,
          lv.int.names = lv.int.names,
          dummy.lv.names = lv.names.b[dummy.lv.idx],
          alpha.correction = local.options[["alpha.correction"]],
          lambda.correction = local.options[["lambda.correction"]],
          #fs.outlier.idx = fs.outlier.idx[[b]],
          return.FS = return.FS,
          return.cov.iveta2 = return.cov.iveta2,
          extra = TRUE
        )
        VETA[[b]] <- tmp[, , drop = FALSE] # drop attributes
        alpha[[b]] <- attr(tmp, "alpha")
        lambda[[b]] <- attr(tmp, "lambda.star")
        MSM..[[b]] <- attr(tmp, "MSM")
        MTM..[[b]] <- attr(tmp, "MTM")
		FS.mean[[b]] <- attr(tmp, "FS.mean")
        if (return.FS) {
          FS[[b]] <- attr(tmp, "FS")
        }
        if (return.cov.iveta2) {
          COV.IVETA2[[b]] <- attr(tmp, "cov.iveta2")
        }
        #FS.gamma[[b]] <- attr(tmp, "FS.gamma")
      } else {
        lav_msg_fixme("not ready yet!")
        # FSR -- no correction
        VETA[[b]] <- lav_sam_fs2(
          FS = FS.b,
          lv.names = lv.names1, lv.int.names = lv.int.names
        )
      }
    }

    # store Mapping matrix for this block
    M[[b]] <- Mb
  } # blocks

  # label blocks
  if (nblocks > 1L) {
    names(EETA)       <- FIT@Data@block.label
    names(VETA)       <- FIT@Data@block.label
    names(REL)        <- FIT@Data@block.label
	names(MSM..)      <- FIT@Data@block.label
	names(MTM..)      <- FIT@Data@block.label
	names(FS.mean)    <- FIT@Data@block.label
    names(FS)         <- FIT@Data@block.label
    names(COV.IVETA2) <- FIT@Data@block.label
    #names(fs.outlier.idx) <- FIT@Data@block.label
    #names(FS.gamma) <- FIT@Data@block.label
  }

  # handle conditional.x: add res.slopes, cov.x and mean.x
  if (FIT@Model@conditional.x) {
    res.slopes <- vector("list", length = nblocks)
    for (b in seq_len(nblocks)) {
      res.slopes[[b]] <- M[[b]] %*% FIT@h1$implied$res.slopes[[b]]
    }
    attr(VETA, "res.slopes") <- res.slopes
    attr(VETA, "cov.x") <- FIT@h1$implied$cov.x
    attr(VETA, "mean.x") <- FIT@h1$implied$mean.x
  }

  # store EETA/VETA/M/alpha/lambda
  STEP1$VETA     <- VETA
  STEP1$EETA     <- EETA
  STEP1$REL      <- REL
  STEP1$M        <- M
  STEP1$lambda   <- lambda
  STEP1$alpha    <- alpha
  STEP1$MSM      <- MSM..
  STEP1$MTM      <- MTM..
  STEP1$FS.mean  <- FS.mean
  STEP1$FS       <- FS
  STEP1$COV.IVETA2 <- COV.IVETA2
  #STEP1$fs.outlier.idx <- fs.outlier.idx
  #STEP1$FS.gamma <- FS.gamma
  STEP1$LV.NAMES <- LV.NAMES
  # store also sam.method and local.options
  STEP1$sam.method <- sam.method
  STEP1$local.options <- local.options

  if (lav_verbose()) {
    cat("done.\n")
  }

  STEP1
}


lav_sam_step1_local_jac <- function(STEP1 = NULL, FIT = NULL, P.only = FALSE,
                                    return.jac = FALSE) {

  lavdata <- FIT@Data
  lavsamplestats <- FIT@SampleStats
  lavmodel <- FIT@Model
  lavpta <- FIT@pta
  nblocks <- lavpta$nblocks

  local.options <- STEP1$local.options
  sam.method <- STEP1$sam.method

  ngroups <- lavdata@ngroups
  if (ngroups > 1L) {
    lav_msg_stop(gettext("IJ local SEs: not available with multiple groups!\n"))
    # if multiple groups:
    # - we have a separate Gamma, h1.expected, delta matrix per group
    # - but we have only 1 observed information matrix, reflecting possible
    #   across-group equality constraints
    # - we may need to use the same procedure as for robust test statistics:
    #   create a (huge) block-diagonal Gamma matrix, and one big 'JAC'
    #   matrix...
  }
  g <- 1L
  if (lavmodel@categorical) {
    lav_msg_stop(gettext("IJ local SEs: not available for the categorical setting (yet)!\n"))
  }
  nMMblocks <- length(STEP1$MM.FIT)

  # JAC = (JACc %*% JACa) + JACb
  # - rows are the elements of vech(VETA)
  # - cols are the elements of vech(S)

  # JACa: mm.theta x vech(S)
  # JACc: vech(VETA) x mm.theta (keeping S fixed)
  # JACb: vech(VETA) x vech(S)  (keeping mm.theta fixed)

  # JACa: jacobian of theta.mm = f(vech(S))
  JACa <- matrix(0, nrow = length(FIT@ParTable$lhs), # we select later
                    ncol = length(FIT@SampleStats@WLS.obs[[g]]))
  for (mm in seq_len(nMMblocks)) {
    fit.mm.block <- STEP1$MM.FIT[[mm]]
    mm.h1.expected   <- lavTech(fit.mm.block, "h1.information.expected")
    mm.delta         <- lavTech(fit.mm.block, "Delta")
    if (P.only && FIT@Options$information[1] == "expected") {
      # for twostep.robust
      mm.inv.observed <- lavTech(fit.mm.block, "inverted.information.expected")
    } else {
      mm.inv.observed  <- lavTech(fit.mm.block, "inverted.information.observed")
    }

    #h1.info <- matrix(0, nrow(mm.h1.expected[[1]]), ncol(mm.h1.expected[[1]]))
    #for (g in seq_len(ngroups)) {
    #  fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal
    #  tmp <- fg * (mm.h1.expected[[g]] %*% mm.delta[[g]])
    #  h1.info <- h1.info + tmp
    #}
    mm.jac <- t(mm.h1.expected[[g]] %*% mm.delta[[g]] %*% mm.inv.observed)
    # keep only rows that are also in FIT@ParTable
    mm.keep.idx <- fit.mm.block@ParTable$free[STEP1$block.ptm.idx[[mm]]]
    mm.jac <- mm.jac[mm.keep.idx, , drop = FALSE]

    # select 'S' elements (row index)
    mm.ov.idx <- match(STEP1$MM.FIT[[mm]]@Data@ov.names[[g]],
                       lavdata@ov.names[[g]])
    mm.nvar <- length(lavdata@ov.names[[g]])
    mm.col.idx <- lav_matrix_vech_which_idx(mm.nvar, idx = mm.ov.idx,
      add.idx.at.start = lavmodel@meanstructure)
    mm.row.idx <- STEP1$block.mm.idx[[mm]][STEP1$block.ptm.idx[[mm]]]
    JACa[mm.row.idx, mm.col.idx] <- mm.jac
  }

  # keep only 'LAMBDA/THETA' parameters
  PT <- STEP1$PT
  # only ov.names that are actually used in the measurement models
  ov.names <- unique(unlist(lapply(STEP1$MM.FIT, lav_object_vnames, "ov")))
  lambda.idx <- which(PT$op == "=~" & PT$free > 0L & !duplicated(PT$free))
  theta.idx  <- which(PT$op == "~~" & PT$free > 0L & !duplicated(PT$free) &
                      PT$lhs %in% ov.names & PT$rhs %in% ov.names)
  nu.idx <- integer(0L)
  if (lavmodel@meanstructure) {
    nu.idx     <- which(PT$op == "~1" & PT$free > 0L & !duplicated(PT$free) &
                        PT$lhs %in% ov.names)
  }
  delta.idx <- integer(0L)
  if (lavmodel@categorical || lavmodel@correlation) {
    delta.idx <- which(PT$op == "~*~" & PT$free > 0L & !duplicated(PT$free))
  }
  beta.idx <- psi.idx <- integer(0L)
  lv.ind <- unlist(lavpta$vnames$lv.ind)
  if (length(lv.ind) > 0L) {
    beta.idx <- which(PT$op == "=~" & PT$free > 0L & !duplicated(PT$free) &
                      PT$rhs %in% lv.ind)
    psi.idx <- which(PT$op == "~~" & PT$free > 0L & !duplicated(PT$free) &
                     PT$rhs %in% lv.ind & PT$lhs %in% lv.ind)
  }
  # keep only these free parameters (measurement only)
  keep.idx <- sort(c(lambda.idx, theta.idx, nu.idx,
                     delta.idx, beta.idx, psi.idx))
  JACa <- JACa[keep.idx, ,drop = FALSE]
  if (P.only) {
    return(JACa)
  }

  # JACb: jacobian of the function vech(VETA) = f(vech(S), theta.mm)
  #       (treating theta.mm as fixed)
  if (length(unlist(lavpta$vnames$lv.interaction)) > 0L) {
    ffb <- function(x) {
      if (lavmodel@meanstructure) {
        nvar <- nrow(FIT@h1$implied$cov[[g]])
        this.ybar <- x[seq_len(nvar)]
        this.cov <- lav_matrix_vech_reverse(x[-seq_len(nvar)])
      } else {
        this.ybar <- FIT@h1$implied$mean[[g]]
        this.cov <- lav_matrix_vech_reverse(x)
      }

      # change COV/YBAR
      step1 <- STEP1
      step1$COV[[1]] <- this.cov
      if (lavmodel@meanstructure) {
        step1$YBAR[[1]] <- this.ybar
      }

      # transform data to comply with the new COV/YBAR
      Y <- FIT@Data@X[[1]]
      Ytrans <- vector("list", nblocks)
      Ytrans[[1]] <- lav_matrix_transform_mean_cov(Y, target.mean = this.ybar,
                                                   target.cov = this.cov)
      colnames(Ytrans[[1]]) <- FIT@pta$vnames$ov[[1]]

      step1 <- lav_sam_step1_local(STEP1 = step1, FIT = FIT, Y = Ytrans,
           sam.method = STEP1$sam.method, local.options = STEP1$local.options)
      if (lavmodel@meanstructure) {
        out <- c(step1$EETA[[1]], lav_matrix_vech(step1$VETA[[1]]))
      } else {
        out <- lav_matrix_vech(step1$VETA[[1]])
      }
      out
    }
    # shut off verbose
    verbose.flag <- lav_verbose()
    lav_verbose(FALSE)
    this.x <- lav_matrix_vech(FIT@h1$implied$cov[[g]])
    if (lavmodel@meanstructure) {
      this.x <- c(FIT@h1$implied$mean[[g]], this.x)
    }
    JACb <- numDeriv::jacobian(func = ffb, x = this.x)
    lav_verbose(verbose.flag)
    # lv.names1 <- STEP1$LV.NAMES[[g]]
    # lv.int.names <- FIT@pta$vnames$lv.interaction[[g]]
    # nfac <- length(lv.names1)

    # idx1 <- rep(seq_len(nfac), each = nfac)
    # idx2 <- rep(seq_len(nfac), times = nfac)

    # NAMES <- paste(lv.names[idx1], lv.names[idx2], sep = ":")



    # JACb <- lav_sam_step1_local_jac_var2(ybar = STEP1$YBAR[[g]],
    #   S = STEP1$COV[[g]], M = STEP1$M[[g]], NU = STEP1$NU[[g]])
    # JACb <- JACb[STEP1$lv.keep2, , drop = FALSE]
    # if (lavmodel@meanstructure) {
    #   tmp <- lav_sam_step1_local_jac_mean2(ybar = STEP1$YBAR[[g]],
    #     M = STEP1$M[[g]], NU = STEP1$NU[[g]])
    #   dd
    #   JACb <- lav_matrix_bdiag(tmp, JACb)
    # }

  } else { # no latent interactions
    Mb <- STEP1$M[[g]]
    MbxMb <- Mb %x% Mb
    row.idx <- lav_matrix_vech_idx(nrow(Mb))
    JACb <- lav_matrix_duplication_post(MbxMb)[row.idx,,drop = FALSE]
    if (lavmodel@meanstructure) {
      JACb <- lav_matrix_bdiag(Mb, JACb)
    }
  }

  # JACc: jacobian of the function vech(VETA) = f(theta.mm, vech(S))
  #       (treating vech(S) as fixed)

  # ffc <- function(x, YBAR = NULL, COV = NULL, b = 1L) {
  #   # x only contains the LAMBDA/THETA/NU elements
  #   PT$est[keep.idx] <- x
  #   # get all free parameters (for lav_model_set_parameters)
  #   x.free <- PT$est[PT$free > 0L & !duplicated(PT$free)]
  #   this.model <- lav_model_set_parameters(lavmodel, x = x.free)
  #   lambda.idx <- which(names(this.model@GLIST) == "lambda")[b]
  #   theta.idx  <- which(names(this.model@GLIST) ==  "theta")[b]
  #   LAMBDA <- this.model@GLIST[[lambda.idx]]
  #   THETA  <- this.model@GLIST[[ theta.idx]]
  #   Mb <- lav_sam_mapping_matrix(LAMBDA = LAMBDA,
  #                                THETA = THETA, S = COV,
  #                                method = local.options$M.method)
  #   # handle observed-only variables
  #   dummy.ov.idx <- c(
  #     FIT@Model@ov.x.dummy.ov.idx[[b]],
  #     FIT@Model@ov.y.dummy.ov.idx[[b]]
  #   )
  #   dummy.lv.idx <- c(
  #     FIT@Model@ov.x.dummy.lv.idx[[b]],
  #     FIT@Model@ov.y.dummy.lv.idx[[b]]
  #   )
  #   if (length(dummy.ov.idx)) {
  #     Mb[dummy.lv.idx, ] <- 0
  #     Mb[cbind(dummy.lv.idx, dummy.ov.idx)] <- 1
  #   }
  #   MSM <- Mb %*% COV %*% t(Mb)
  #   MTM <- Mb %*% THETA %*% t(Mb)
  #   VETA <- MSM - MTM

  #   if (lavmodel@meanstructure) {
  #     nu.idx <- which(names(this.model@GLIST) ==  "nu")[b]
  #     NU <- this.model@GLIST[[nu.idx]]
  #     EETA <- lav_sam_eeta(M = Mb, YBAR = YBAR, NU = NU)
  #     out <- c(EETA, lav_matrix_vech(VETA))
  #   } else {
  #     out <- lav_matrix_vech(VETA)
  #   }

  #   out
  # }

  # current point estimates
  # PT <- STEP1$PT
  # x <- PT$est[keep.idx]
  # if (lavmodel@meanstructure) {
  #   JACc <- numDeriv::jacobian(func = ffc, x = x, YBAR = STEP1$YBAR[[1]],
  #                              COV = STEP1$COV[[1]])
  # } else {
  #   JACc <- numDeriv::jacobian(func = ffc, x = x, COV = STEP1$COV[[1]])
  # }

  # calling lav_sam_step1_local() directly
  ffc <- function(x) {
    step1 <- STEP1

    # fill in new 'x' values in PT
    step1$PT$est[keep.idx] <- x
    step1 <- lav_sam_step1_local(STEP1 = step1, FIT = FIT,
           sam.method = STEP1$sam.method, local.options = STEP1$local.options)
    if (lavmodel@meanstructure) {
      out <- c(step1$EETA[[1]], lav_matrix_vech(step1$VETA[[1]]))
    } else {
      out <- lav_matrix_vech(step1$VETA[[1]])
    }
    out
  }
  # shut off verbose
  verbose.flag <- lav_verbose()
  lav_verbose(FALSE)
  JACc <- numDeriv::jacobian(func = ffc, x = STEP1$PT$est[keep.idx])
  lav_verbose(verbose.flag)

  # assemble JAC
  JAC <- (JACc %*% JACa) + JACb

  if (return.jac) {
    attr(JAC, "JACa") <- JACa
    attr(JAC, "JACb") <- JACb
    attr(JAC, "JACc") <- JACc
  }

  # eventually, this will be a list per group/block
  list(JAC)
}

lav_sam_step1_local_jac_var2 <- function(ybar = NULL, S = NULL,
                                         M = NULL, NU = NULL) {

  nfac <- nrow(M)
  K.nfac <- lav_matrix_commutation(nfac, nfac)
  IK <- diag(nfac*nfac) + K.nfac

  MEAN.FS <- M %*% (ybar - NU)
  MSM <- M %*% S %*% t(M)

  part1a <- ( diag(nfac) %x% matrix(lav_matrix_vec(IK %*% (MSM %x% diag(nfac)) %*% K.nfac), nfac^3, nfac) +
        matrix(diag(nfac) %x% (IK %*% (diag(nfac) %x% MSM)), nfac^4, nfac^2) )
  tmp1 <- part1a %*% IK %*% (diag(nfac) %x% MEAN.FS) %*% M

# S part
  A <- tcrossprod(MEAN.FS)
  part1b <- diag(nfac) %x% matrix(lav_matrix_vec(IK %*% (A %x% diag(nfac)) %*% K.nfac), nfac^3, nfac)
  part1c <- matrix(diag(nfac) %x% (IK %*% (diag(nfac) %x% A)), nfac^4, nfac^2)
  tmp2 <- (part1a + part1b + part1c) %*% lav_matrix_duplication_post(M %x% M)

  # together
  JAC.S.analytic <- cbind(tmp1, tmp2)
  JAC.S.analytic
}

lav_sam_step1_local_jac_mean2 <- function(ybar = NULL, M = NULL, NU = NULL) {
  nfac <- nrow(M)
  K.nfac <- lav_matrix_commutation(nfac, nfac)
  IK <- diag(nfac*nfac) + K.nfac

  MEAN.FS <- M %*% (ybar - NU)

  tmp1 <- IK %*% (diag(nfac) %x% MEAN.FS) %*% M
  tmp2 <- lav_matrix_duplication_post(M %x% M)
  JAC.M.analytic <- cbind(tmp1, tmp2)
  JAC.M.analytic
}

lav_sam_gamma_add_numerical <- function(STEP1 = NULL, FIT = NULL, group = 1L) {

  lavdata <- FIT@Data
  lavsamplestats <- FIT@SampleStats
  lavmodel <- FIT@Model
  lavpta <- FIT@pta
  nblocks <- lavpta$nblocks

  local.options <- STEP1$local.options
  sam.method <- STEP1$sam.method

  ngroups <- lavdata@ngroups
  if (ngroups > 1L) {
    lav_msg_stop(gettext("IJ local SEs: not available with multiple groups!\n"))
  }
  g <- group
  Y <- FIT@Data@X[[g]]
  N <- nrow(Y)

  # NAMES + lv.keep
  lv.names <- STEP1$LV.NAMES[[1]]
  lv.names <- c("..int..", lv.names)
  nfac <- length(lv.names)
  idx1 <- rep(seq_len(nfac), each = nfac)
  idx2 <- rep(seq_len(nfac), times = nfac)

  K.nfac <- lav_matrix_commutation(nfac, nfac)
  IK <- diag(nfac * nfac) + K.nfac

  NAMES <- paste(lv.names[idx1], lv.names[idx2], sep = ":")
  NAMES[seq_len(nfac)] <- lv.names
  lv.keep <- colnames(STEP1$VETA[[1]])
  FS.mean <- STEP1$FS.mean[[1]]
  keep.idx <- match(lv.keep, NAMES)

  theta.to.eetavetai <- function(x, i = 1L) {
    PT <- STEP1$PT
    PT$est[step1.idx] <- x
    this.lavmodel <- lav_model_set_parameters(lavmodel,
                       x = PT$est[PT$free > 0 & !duplicated(PT$free)])
    this.nu     <- this.lavmodel@GLIST$nu
    rm.idx <- lavpta$vidx$lv.interaction[[1]]
    # no interaction columns!
    this.lambda <- this.lavmodel@GLIST$lambda[, -rm.idx,drop = FALSE]
    this.theta  <- this.lavmodel@GLIST$theta
    this.M <- lav_sam_mapping_matrix(LAMBDA = this.lambda,
                                     THETA = this.theta,
                                     S = STEP1$COV[[1]],
                                     method = STEP1$local.options$M.method)
    MTM <- this.M %*% this.theta %*% t(this.M)
    MTM <- lav_matrix_bdiag(0,MTM)

    fi <- this.M %*% (Y[i,] - this.nu); fi <- rbind(1, fi); fii <- drop(fi)
    fi2 <- (fii[idx1]*fii[idx2])

    tmp <- ( ((tcrossprod(fi) - MTM) %x% MTM) +
             (MTM %x% (tcrossprod(fi) - MTM)) +
             lav_matrix_commutation_post((tcrossprod(fi) - MTM) %x% MTM) +
             lav_matrix_commutation_pre((tcrossprod(fi) - MTM) %x% MTM) +
             (IK %*% (MTM %x% MTM)) )

    # we have no access to FS2.mean, so we need to reduce the matrices
    # right away
    f.star <- tcrossprod(fi2[keep.idx] - FS.mean)
    e.star <- STEP1$lambda[[1]] * tmp[keep.idx, keep.idx, drop = FALSE]
    iveta2 <- f.star - e.star
    #iveta  <- iveta2[seq_len(nfac - 1), seq_len(nfac - 1)]

    ieeta2 <- ( lav_matrix_vec(tcrossprod(fi))[keep.idx] -
                lav_matrix_vec(tcrossprod(FS.mean))[keep.idx] +
                (FS.mean %x% FS.mean)[keep.idx] -
                STEP1$lambda[[1]] * lav_matrix_vec(MTM)[keep.idx] )

    c(ieeta2, lav_matrix_vech(iveta2))
  } # single 'i'

  step1.idx <- which(STEP1$PT$free %in% STEP1$step1.free.idx)
  x.step1 <- STEP1$PT$est[step1.idx]
  try.one <- theta.to.eetavetai(x = x.step1, i = 1)
  CVETA <- matrix(0, nrow = length(try.one), ncol = length(x.step1))
  for(i in 1:N) {
    tmp <- numDeriv::jacobian(func = theta.to.eetavetai, x = x.step1, i = i)
    CVETA <- CVETA + 1/N * tmp
  }

  Gamma.addition <- N * (CVETA %*% STEP1$Sigma.11 %*% t(CVETA))
  Gamma.addition
}

# semi-analytic version
# YR 4 June 2025: works, but still needs cleanup + avoid redundant calculations
# (eg when multiplied with a matrix with many zero rows/cols)
lav_sam_gamma_add <- function(STEP1 = NULL, FIT = NULL, group = 1L) {

  lavdata <- FIT@Data
  lavsamplestats <- FIT@SampleStats
  lavmodel <- FIT@Model
  lavpta <- FIT@pta
  nblocks <- lavpta$nblocks

  local.options <- STEP1$local.options
  sam.method <- STEP1$sam.method

  ngroups <- lavdata@ngroups
  if (ngroups > 1L) {
    lav_msg_stop(gettext("IJ local SEs: not available with multiple groups!\n"))
  }
  g <- group
  Y <- FIT@Data@X[[g]]
  N <- nrow(Y)
  P <- ncol(Y)

  # NAMES + lv.keep
  lv.names <- STEP1$LV.NAMES[[1]]
  lv.names <- c("..int..", lv.names)
  nfac <- length(lv.names)
  idx1 <- rep(seq_len(nfac), each = nfac)
  idx2 <- rep(seq_len(nfac), times = nfac)

  K.nfac <- lav_matrix_commutation(nfac, nfac)
  IK <- diag(nfac * nfac) + K.nfac
  D <- lav_matrix_duplication(nfac)

  NAMES <- paste(lv.names[idx1], lv.names[idx2], sep = ":")
  NAMES[seq_len(nfac)] <- lv.names
  lv.keep <- colnames(STEP1$VETA[[1]])
  FS.mean <- STEP1$FS.mean[[1]]
  keep.idx <- match(lv.keep, NAMES)

  # step 1 free parameters
  step1.idx <- which(STEP1$PT$free %in% STEP1$step1.free.idx)
  x.step1 <- STEP1$PT$est[step1.idx]

  this.nu <- STEP1$NU[[1]]
  this.M  <- STEP1$M[[1]]
  this.MTM <- lav_matrix_bdiag(0, STEP1$MTM[[1]][seq_len(nfac - 1), seq_len(nfac - 1)])
  this <- c(this.nu, lav_matrix_vec(this.M), lav_matrix_vech(this.MTM))
  INDEX <- matrix(seq_len(nfac^2 * nfac^2), nfac^2, nfac^2)

  x2this <- function(x) {
    PT <- STEP1$PT
   PT$est[step1.idx] <- x
    this.lavmodel <- lav_model_set_parameters(lavmodel,
                       x = PT$est[PT$free > 0 & !duplicated(PT$free)])
    this.nu     <- this.lavmodel@GLIST$nu
    rm.idx <- lavpta$vidx$lv.interaction[[1]]
    # no interaction columns!
    this.lambda <- this.lavmodel@GLIST$lambda[, -rm.idx,drop = FALSE]
    this.theta  <- this.lavmodel@GLIST$theta
    this.M <- lav_sam_mapping_matrix(LAMBDA = this.lambda,
                                     THETA = this.theta,
                                     S = STEP1$COV[[1]],
                                     method = STEP1$local.options$M.method)
    MTM <- this.M %*% this.theta %*% t(this.M)
    MTM <- lav_matrix_bdiag(0,MTM)

    out <- c(this.nu, lav_matrix_vec(this.M), lav_matrix_vech(MTM))
    out
  }
  JAC.x2this <- numDeriv::jacobian(func = x2this, x = x.step1)
  # 46 x 24

  # JAC.eetai2.this
  JAC.eeta2.this <- matrix(0, nrow = length(STEP1$EETA[[1]]), ncol = length(this))
  pstar <- nfac * (nfac + 1) / 2
  idx <- P + length(this.M) + seq_len(pstar)
  JAC.eeta2.this[,idx] <- (-diag(nfac^2) %*% D)[keep.idx,]

  # define function for JAC.veta2.fi
  get.JAC.veta2.fi <- function(x, MTM, FS.MEAN = NULL, lambda.star = 1, keep.idx = NULL) {
    fi <- drop(fi)
    P <- length(fi)
    stopifnot(P == ncol(MTM))

    #INDEX <- matrix(seq_len(P^2 * P^2), P^2, P^2)

    # (tcrossprod(fi) - MTM) %x% MTM) -- part A
    block.a <- fi %x% do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% MTM[,i]))
    long.a <- diag(P) %x% lav_matrix_vec(fi %x% MTM)
    big.a <- block.a + long.a
    part.a <- big.a[lav_matrix_vech(INDEX[keep.idx, keep.idx]),]

    # (MTM %x% (tcrossprod(fi) - MTM)) -- part B
    block.b <- lav_matrix_vec(fi %x% MTM) %x% diag(P)
    long.b <- do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% MTM[,i])) %x% fi
    big.b <- block.b + long.b
    part.b <- big.b[lav_matrix_vech(INDEX[keep.idx, keep.idx]),]

    # lav_matrix_commutation_post((tcrossprod(fi) - MTM) %x% MTM) -- part C
    block.c <- do.call("rbind", lapply(seq_len(P), function(i) fi %x% (diag(P) %x% MTM[,i])))
    long.c  <- do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% (fi %x% MTM[,i])))
    big.c <- block.c + long.c
    part.c <- big.c[lav_matrix_vech(INDEX[keep.idx, keep.idx]),]

    # lav_matrix_commutation_pre((tcrossprod(fi) - MTM) %x% MTM) -- part D
    long.d <- diag(P) %x% lav_matrix_vec(MTM %x% fi)
    block.d <- (fi %x% lav_matrix_vec(MTM)) %x% diag(P)
    big.d <- block.d + long.d
    part.d <- big.d[lav_matrix_vech(INDEX[keep.idx, keep.idx]),]

    # t1 (tcrossprod(fi2[keep.idx] - FS.mean) only) -- part E
    idx1 <- rep(seq_len(P), each = P)
    idx2 <- rep(seq_len(P), times = P)
    fi2 <- (fi[idx1]*fi[idx2])
    fik <- fi2[keep.idx]

    fi <- as.matrix(fi)
    tt <- ((fi %x% diag(P))[keep.idx,] + (diag(P) %x% fi)[keep.idx,])
    tmp <- ((fik - FS.mean) %x% tt) + (tt %x% (fik - FS.mean))
    part.e <- tmp[lav_matrix_vech_idx(length(fik)),]

    final <- part.e - lambda.star * (part.a + part.b + part.c + part.d)
    final
  }

  # define function for JAC.veta2.this.i
  get.JAC.veta2.this <- function(x, fi = NULL, lambda.star = 1, keep.idx = NULL) {
    nvar <- ncol(STEP1$M[[1]])
    nfac <- nrow(STEP1$M[[1]])
    this.nu <- x[seq_len(nvar)]; x <- x[-seq_len(nvar)]
    this.M  <- matrix(x[seq_len(nvar*nfac)], nrow = nfac, ncol = nvar)
    x <- x[-seq_len(nvar*nfac)]
    MTM <- lav_matrix_vech_reverse(x)
    fi <- as.matrix(fi)
    P <- nrow(fi)

    # part a: ((tcrossprod(fi) - MTM) %x% MTM)
    long.a <- diag(P) %x% do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% -MTM[,i]))
    block.a <- do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% (tcrossprod(fi) - MTM)[,i])) %x% diag(P)
    big.a.vec <- long.a + block.a
    big.a <- big.a.vec %*% D
    part.a <- big.a[lav_matrix_vech(INDEX[keep.idx, keep.idx]),]

    # part b: (MTM %x% (tcrossprod(fi) - MTM))
    block.b <- do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% -MTM[,i])) %x% diag(P)
    long.b <- diag(P) %x% do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% (tcrossprod(fi) - MTM)[,i]))
    big.b.vec <- block.b + long.b
    big.b <- big.b.vec %*% D
    part.b <- big.b[lav_matrix_vech(INDEX[keep.idx, keep.idx]),]

    # part c: lav_matrix_commutation_post((tcrossprod(fi) - MTM) %x% MTM)
    block.c <- diag(P) %x% do.call("rbind", lapply(seq_len(P), function(i) ((tcrossprod(fi) - MTM)[,i]) %x% diag(P)))
    long.c <- do.call("rbind", lapply(seq_len(P), function(i) diag(P*P) %x% (-MTM[,i]) ))
    big.c.vec <- block.c + long.c
    big.c <- big.c.vec %*% D
    part.c <- big.c[lav_matrix_vech(INDEX[keep.idx, keep.idx]),]

    # part d: lav_matrix_commutation_pre((tcrossprod(fi) - MTM) %x% MTM)
    block.d <- diag(P) %x% do.call("rbind", lapply(seq_len(P), function(i) -MTM[,i] %x% diag(P)))
    long.d <- do.call("rbind", lapply(seq_len(P), function(i) diag(P*P) %x% ((tcrossprod(fi) - MTM)[,i]) ))
    big.d.vec <- block.d + long.d
    big.d <- big.d.vec %*% D
    part.d <- big.d[lav_matrix_vech(INDEX[keep.idx, keep.idx]),]

    # part e: (IK %*% (MTM %x% MTM))
    K <- lav_matrix_commutation(P, P)
    e1 <- diag(P) %x% do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% MTM[,i]))
    e2 <- do.call("rbind", lapply(seq_len(P), function(i) diag(P*P) %x% MTM[,i] ))
    e3 <- do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% MTM[,i])) %x% diag(P)
    e4 <- diag(P) %x% do.call("rbind", lapply(seq_len(P), function(i) K %*% (diag(P) %x% MTM[,i])))
    big.e.vec <- e1 + e2 + e3 + e4
    big.e <- big.e.vec %*% D
    part.e <-  big.e[lav_matrix_vech(INDEX[keep.idx, keep.idx]),]

    final <- -1 * lambda.star * (part.a + part.b + part.c + part.d + part.e)
    final
  }

  n_eeta_veta <- length(STEP1$EETA[[1]]) + length(lav_matrix_vech(STEP1$VETA[[1]]))
  CVETA <- matrix(0, nrow = n_eeta_veta, ncol = length(x.step1))
  for(i in 1:N) {
    # experimental: remove fs outliers
    #if (i %in% STEP1$fs.outlier.idx[[1]]) {
    #  next
    #}

    # factor score
    fi <- rbind(1, this.M %*% (Y[i,] - this.nu))

    #tmp <- numDeriv::jacobian(func = theta.to.eetavetai, x = x.step1, i = i)
    JAC.this2fi.i <- rbind(0, cbind(-1 * this.M,
                           t(as.matrix(Y[i,] - drop(this.nu))) %x% diag(nrow(this.M)),
                           matrix(0, nrow = nrow(this.M), ncol = length(lav_matrix_vech(this.MTM)))))

    JAC.eeta2.fi.i <- ((fi %x% diag(nfac)) + (diag(nfac) %x% fi))[keep.idx,]
    EETA2 <- ((JAC.eeta2.fi.i %*% JAC.this2fi.i) + JAC.eeta2.this) %*% JAC.x2this

    JAC.veta2.fi.i <- get.JAC.veta2.fi(x = fi, MTM = this.MTM, FS.MEAN = FS.mean,
                                       lambda.star = STEP1$lambda[[1]], keep.idx = keep.idx)
    JAC.veta2.this.i <- matrix(0, nrow = nrow(JAC.veta2.fi.i), ncol = ncol(JAC.this2fi.i))
    JAC.veta2.this.i[,idx] <- get.JAC.veta2.this(x = this, fi = fi,
                                                 lambda.star = STEP1$lambda[[1]],
                                                 keep.idx = keep.idx)
    VETA2 <- ((JAC.veta2.fi.i %*% JAC.this2fi.i) + JAC.veta2.this.i) %*% JAC.x2this

    # FIXME: remove outliers somehow?
    CVETA <- CVETA + 1/N * rbind(EETA2, VETA2)
  }

  Gamma.addition <- N * (CVETA %*% STEP1$Sigma.11 %*% t(CVETA))
  Gamma.addition
}



# LDW 11/4/24 : overwrite defaults depending on mimic in separate function
#
lav_options_mimic <- function(opt) {
  mlr.test <- "yuan.bentler.mplus" # for now
  if (opt$gls.v11.mplus == "default") {
    opt$gls.v11.mplus <- (opt$mimic == "Mplus")
  }
  if (opt$gamma.vcov.mplus == "default") {
    opt$gamma.vcov.mplus <- (opt$mimic == "Mplus")
  }
  if (opt$gamma.wls.mplus == "default") {
    opt$gamma.wls.mplus <- (opt$mimic == "Mplus")
  }
  if (opt$information.expected.mplus == "default") {
    opt$information.expected.mplus <- (opt$mimic == "Mplus")
  }
  if (opt$mimic == "lavaan") {
    if (is.character(opt$conditional.x)) { # = "default"
      if (lav_options_estimatorgroup(opt$estimator) == "ML") {
        opt$conditional.x <- FALSE
      }
    }
    if (opt$fixed.x == "default") {
      if (any(lav_options_estimatorgroup(opt$estimator) == c("MML", "ML", "IV")) &&
          is.character(opt$start) && opt$start != "simple") { # new in 0.6-12
        opt$fixed.x <- TRUE
      }
    }
    if (is.character(opt$zero.keep.margins)) { # = "default"
      opt$zero.keep.margins <- TRUE
    }
  } else if (opt$mimic == "Mplus") {
    if (length(opt$group.equal) == 0L || all(nchar(opt$group.equal) == 0L)) {
      if (opt$.categorical) {
        opt$group.equal <- c("loadings", "thresholds")
      } else {
        if (is.logical(opt$meanstructure) && !opt$meanstructure) {
          opt$group.equal <- "loadings"
        } else {
          opt$group.equal <- c("loadings", "intercepts")
        }
      }
    }
    if (opt$missing == "default") {
      if (!opt$.categorical && any(opt$estimator == c("ml", "mlr")))
      {
        # since version 5?
        opt$missing <- "ml"
        # check later if this is ok
      }
    }
    if (opt$estimator != "pml") {
      if (opt$meanstructure == "default") opt$meanstructure <- TRUE
    }
    if (opt$estimator == "mlr") mlr.test <- "yuan.bentler.mplus"
    if (any(lav_options_estimatorgroup(opt$estimator) ==
            c("ML", "REML", "NTRLS", "catML"))) {
      }
    if (is.character(opt$conditional.x)) { # = "default"
      if (lav_options_estimatorgroup(opt$estimator) == "ML") {
        opt$conditional.x <- FALSE
      }
    }
    if (opt$fixed.x == "default") {
      if (any(lav_options_estimatorgroup(opt$estimator) == c("MML", "ML")) &&
          is.character(opt$start) && opt$start != "simple") { # new in 0.6-12
        opt$fixed.x <- TRUE
      }
    }
    if (is.character(opt$zero.keep.margins)) { # = "default"
      opt$zero.keep.margins <- TRUE
    }
    opt$baseline.conditional.x.free.slopes <- FALSE
  } else if (opt$mimic == "EQS") {
    opt$baseline.fixed.x.free.cov <- FALSE
    if (opt$estimator == "mlr") mlr.test <- "yuan.bentler"
    if (any(lav_options_estimatorgroup(opt$estimator) ==
            c("ML", "REML", "NTRLS", "catML"))) {
      if (opt$likelihood == "default") opt$likelihood <- "wishart"
    }
  } else if (opt$mimic == "LISREL") {
    opt$baseline.fixed.x.free.cov <- FALSE
    if (any(lav_options_estimatorgroup(opt$estimator) ==
            c("ML", "REML", "NTRLS", "catML"))) {
      if (opt$likelihood == "default") opt$likelihood <- "wishart"
    }
  }
  if (opt$estimator == "mlr") {
    if (opt$test[1] == "default") {
      opt$test <- mlr.test
    } else {
      opt$test <- union(mlr.test, opt$test)
    }
  }
  opt
}

# the 'multiple group' method as described in Guttman, 1952
#
# Guttman, L. (1952). Multiple group methods for common-factor analysis,
# their basis, computation, and interpretation. Psychometrika, 17(2) 209--222
#
# YR 02 Feb 2023: - first version in lavaan, using quadprog (no std.lv yet)

lav_cfa_guttman1952 <- function(S,
                                marker.idx = NULL,
                                lambda.nonzero.idx = NULL,
                                theta = NULL, # vector!
                                theta.bounds = FALSE,
                                force.pd = FALSE,
                                zero.after.efa = FALSE,
                                quadprog = FALSE,
                                psi.mapping = FALSE,
                                nobs = 20L) { # for cutoff
  # dimensions
  nvar <- ncol(S)
  nfac <- length(marker.idx)
  stopifnot(length(theta) == nvar)

  # overview of lambda structure
  B <- matrix(0, nvar, nfac)
  lambda.marker.idx <- (seq_len(nfac) - 1L) * nvar + marker.idx
  B[lambda.marker.idx] <- 1L
  B[lambda.nonzero.idx] <- 1L

  # this method does not support crossloadings!
  if (any(rowSums(B) > 1)) {
    lav_msg_stop(gettext("the guttman1952 procedure does not support ",
                       "crossloadings; consider fabin or bentler1982 instead"))
  }

  # if we wish to keep SminTheta PD, we must keep theta within bounds
  if (force.pd) {
    theta.bounds <- TRUE
  }
  if (psi.mapping) {
    theta.bounds <- TRUE
    force.pd <- TRUE
  }

  # do we first 'clip' the theta values so they are within standard bounds?
  # (Question: do we need the 0.01 and 0.99 multipliers?)
  diagS <- diag(S)
  if (theta.bounds) {
    # lower bound
    lower.bound <- diagS * 0 # * 0.01
    too.small.idx <- which(theta < lower.bound)
    if (length(too.small.idx) > 0L) {
      theta[too.small.idx] <- lower.bound[too.small.idx]
    }

    # upper bound
    upper.bound <- diagS * 1 # * 0.99
    too.large.idx <- which(theta > upper.bound)
    if (length(too.large.idx) > 0L) {
      theta[too.large.idx] <- upper.bound[too.large.idx]
    }
  }

  # compute SminTheta: S where we replace diagonal with 'communalities'
  diag.theta <- diag(theta, nvar)
  SminTheta <- S - diag.theta
  if (force.pd) {
    lambda <- try(lav_matrix_symmetric_diff_smallest_root(S, diag.theta),
      silent = TRUE
    )
    if (inherits(lambda, "try-error")) {
      lav_msg_warn(gettext("failed to compute lambda"))
      SminTheta <- S - diag.theta # and hope for the best
    } else {
      cutoff <- 1 + 1 / (nobs - 1)
      if (lambda < cutoff) {
        lambda.star <- lambda - 1 / (nobs - 1)
        SminTheta <- S - lambda.star * diag.theta
      } else {
        SminTheta <- S - diag.theta
      }
    }
  } else {
    # at least we force the diagonal elements of SminTheta to be nonnegative
    lower.bound <- diagS * 0.001
    too.small.idx <- which(diag(SminTheta) < lower.bound)
    if (length(too.small.idx) > 0L) {
      diag(SminTheta)[too.small.idx] <- lower.bound[too.small.idx]
    }
  }

  # compute covariances among 1) (corrected) variables, and
  #                           2) (corrected) sum-scores
  YS.COV <- SminTheta %*% B

  # compute covariance matrix of corrected sum-scores
  # SS.COV <- t(B) %*% SminTheta %*% B
  SS.COV <- crossprod(B, YS.COV)

  # scaling factors
  # D.inv.sqrt <- diag(1/sqrt(diag(SS.COV)))
  d.inv.sqrt <- 1 / sqrt(diag(SS.COV))

  # factor correlation matrix
  # PHI <- D.inv.sqrt %*% SS.COV %*% D.inv.sqrt
  PHI <- t(SS.COV * d.inv.sqrt) * d.inv.sqrt

  # factor *structure* matrix
  # (covariances corrected Y & corrected normalized sum-scores)
  # YS.COR <- YS.COV %*% D.inv.sqrt
  YS.COR <- t(YS.COV) * d.inv.sqrt # transposed!

  if (zero.after.efa) {
    # we initially assume a saturated LAMBDA (like EFA)
    # then, we just fix the zero-elements to zero

    LAMBDA <- t(solve(PHI, YS.COR)) # = unconstrained EFA version
    # force zeroes
    LAMBDA <- LAMBDA * B
  } else if (quadprog) {
    # constained version using quadprog
    # only useful if (in)equality constraints are needed (TODo)

    # PHI MUST be positive-definite
    PHI <- cov2cor(lav_matrix_symmetric_force_pd(PHI,
      tol = 1e-04
    )) # option?
    Dmat <- lav_matrix_bdiag(rep(list(PHI), nvar))
    dvec <- as.vector(YS.COR)
    eq.idx <- which(t(B) != 1) # these must be zero (row-wise!)
    Rmat <- diag(nrow(Dmat))[eq.idx, , drop = FALSE]
    bvec <- rep(0, length(eq.idx)) # optional, 0=default
    out <- try(quadprog::solve.QP(
      Dmat = Dmat, dvec = dvec, Amat = t(Rmat),
      meq = length(eq.idx), bvec = bvec
    ), silent = TRUE)
    if (inherits(out, "try-error")) {
      lav_msg_warn(gettext("solve.QP failed to find a solution"))
      Lambda <- B
      Lambda[lambda.nonzero.idx] <- as.numeric(NA)
      Theta <- diag(rep(as.numeric(NA), nvar), nvar)
      Psi <- matrix(as.numeric(NA), nfac, nfac)
      return(list(lambda = Lambda, theta = Theta, psi = Psi))
    } else {
      LAMBDA <- matrix(out$solution, nrow = nvar, ncol = nfac, byrow = TRUE)
      # zap almost zero elements
      LAMBDA[abs(LAMBDA) < sqrt(.Machine$double.eps)] <- 0
    }
  } else {
    # default, if no (in)equality constraints
    LAMBDA <- t(solve(PHI, YS.COR)) # = unconstrained EFA version
    #YS.COR0 <- YS.COR
    #YS.COR0[t(B) != 1] <- 0
    #LAMBDA <- t(YS.COR0)
  }

  # rescale LAMBDA, so that 'marker' indicator == 1
  marker.lambda <- LAMBDA[lambda.marker.idx]
  Lambda <- t(t(LAMBDA) * (1 / marker.lambda))

  # rescale PHI, covariance metric
  Psi <- t(PHI * marker.lambda) * marker.lambda

  # redo psi using ML mapping function?
  if (psi.mapping) {
    Ti <- 1 / theta
    zero.theta.idx <- which(abs(theta) < 0.01) # be conservative
    if (length(zero.theta.idx) > 0L) {
      Ti[zero.theta.idx] <- 1
    }

    # ML mapping function
    M <- solve(t(Lambda) %*% diag(Ti, nvar) %*% Lambda) %*% t(Lambda) %*% diag(Ti, nvar)
    Psi <- M %*% SminTheta %*% t(M)
  }

  list(lambda = Lambda, theta = theta, psi = Psi)
}

# internal function to be used inside lav_optim_noniter
# return 'x', the estimated vector of free parameters
lav_cfa_guttman1952_internal <- function(lavobject = NULL, # convenience
                                         # internal slot
                                         lavmodel = NULL,
                                         lavsamplestats = NULL,
                                         lavpartable = NULL,
                                         lavdata = NULL,
                                         lavoptions = NULL,
                                         theta.bounds = TRUE,
                                         force.pd = TRUE,
                                         zero.after.efa = FALSE,
                                         quadprog = FALSE,
                                         psi.mapping = TRUE) {
  lavpta <- NULL
  if (!is.null(lavobject)) {
    stopifnot(inherits(lavobject, "lavaan"))

    # extract slots
    lavmodel <- lavobject@Model
    lavsamplestats <- lavobject@SampleStats
    lavpartable <- lav_partable_set_cache(lavobject@ParTable, lavobject@pta)
    lavpta <- lavobject@pta
    lavdata <- lavobject@Data
    lavoptions <- lavobject@Options
  }
  if (is.null(lavpta)) {
    lavpta <- lav_partable_attributes(lavpartable)
    lavpartable <- lav_partable_set_cache(lavpartable, lavpta)
  }

  if (missing(zero.after.efa) &&
    !is.null(lavoptions$estimator.args$zero.after.efa)) {
    zero.after.efa <- lavoptions$estimator.args$zero.after.efa
  }

  if (missing(psi.mapping) &&
    !is.null(lavoptions$estimator.args$psi.mapping)) {
    psi.mapping <- lavoptions$estimator.args$psi.mapping
  }

  if (missing(quadprog) &&
    !is.null(lavoptions$estimator.args$quadprog)) {
    quadprog <- lavoptions$estimator.args$quadprog
  }

  # no structural part!
  if (any(lavpartable$op == "~")) {
    lav_msg_stop(gettext("GUTTMAN1952 estimator only available for CFA models"))
  }
  # no BETA matrix! (i.e., no higher-order factors)
  if (!is.null(lavmodel@GLIST$beta)) {
    lav_msg_stop(gettext(
   "GUTTMAN1952 estimator not available for models that require a BETA matrix"))
  }
  # no std.lv = TRUE for now
  if (lavoptions$std.lv) {
    lav_msg_stop(gettext(
      "GUTTMAN1952 estimator not available if std.lv = TRUE"))
  }

  nblocks <- lav_partable_nblocks(lavpartable)
  stopifnot(nblocks == 1L) # for now
  b <- 1L
  sample.cov <- lavsamplestats@cov[[b]]
  nvar <- nrow(sample.cov)
  lv.names <- lavpta$vnames$lv.regular[[b]]
  nfac <- length(lv.names)
  marker.idx <- lavpta$vidx$lv.marker[[b]]
  lambda.idx <- which(names(lavmodel@GLIST) == "lambda")
  lambda.nonzero.idx <- lavmodel@m.free.idx[[lambda.idx]]
  # only diagonal THETA for now...
  # because if we have correlated residuals, we should remove the
  # corresponding variables as instruments before we estimate lambda...
  # (see MIIV)
  theta.idx <- which(names(lavmodel@GLIST) == "theta") # usually '2'
  m.theta <- lavmodel@m.free.idx[[theta.idx]]
  nondiag.idx <- m.theta[!m.theta %in% lav_matrix_diag_idx(nvar)]
  if (length(nondiag.idx) > 0L) {
    lav_msg_warn(gettext(
      "this implementation of FABIN does not handle correlated residuals yet!"))
  }

  # 1. obtain estimate for (diagonal elements of) THETA
  #    for now we use Spearman per factor
  B <- matrix(0, nvar, nfac)
  lambda.marker.idx <- (seq_len(nfac) - 1L) * nvar + marker.idx
  B[lambda.marker.idx] <- 1L
  B[lambda.nonzero.idx] <- 1L
  theta <- numeric(nvar)
  for (f in seq_len(nfac)) {
    ov.idx <- which(B[, f] == 1L)
    S.fac <- sample.cov[ov.idx, ov.idx, drop = FALSE]
    theta[ov.idx] <- lav_cfa_theta_spearman(S.fac, bounds = "wide")
  }

  # 2. run Guttman1952 'Multiple Groups' algorithm
  out <- lav_cfa_guttman1952(
    S = sample.cov, marker.idx = marker.idx,
    lambda.nonzero.idx = lambda.nonzero.idx,
    theta = theta,
    # experimental
    theta.bounds = theta.bounds,
    force.pd = force.pd,
    zero.after.efa = zero.after.efa,
    quadprog = quadprog,
    psi.mapping = psi.mapping,
    #
    nobs = lavsamplestats@ntotal
  )
  LAMBDA <- out$lambda
  THETA <- diag(out$theta, nvar)
  PSI <- out$psi

  # store matrices in lavmodel@GLIST
  lavmodel@GLIST$lambda <- LAMBDA
  lavmodel@GLIST$theta <- THETA
  lavmodel@GLIST$psi <- PSI

  # extract free parameters only
  x <- lav_model_get_parameters(lavmodel)

  # apply bounds (if any)
  if (!is.null(lavpartable$lower)) {
    lower.x <- lavpartable$lower[lavpartable$free > 0]
    too.small.idx <- which(x < lower.x)
    if (length(too.small.idx) > 0L) {
      x[too.small.idx] <- lower.x[too.small.idx]
    }
  }
  if (!is.null(lavpartable$upper)) {
    upper.x <- lavpartable$upper[lavpartable$free > 0]
    too.large.idx <- which(x > upper.x)
    if (length(too.large.idx) > 0L) {
      x[too.large.idx] <- upper.x[too.large.idx]
    }
  }

  x
}

# bootstrap based NVCOV
lav_model_nvcov_bootstrap <- function(lavmodel = NULL,
                                      lavsamplestats = NULL,
                                      lavoptions = NULL,
                                      lavimplied = NULL,
                                      lavh1 = NULL,
                                      lavdata = NULL,
                                      lavcache = NULL,
                                      lavpartable = NULL) {
  # number of bootstrap draws
  if (!is.null(lavoptions$bootstrap)) {
    R <- lavoptions$bootstrap
  } else {
    R <- 1000L
  }

  boot.type <- "ordinary"
  if ("bollen.stine" %in% lavoptions$test) {
    boot.type <- "bollen.stine"
  }

  TEST <- NULL
  COEF <- lav_bootstrap_internal(
    object = NULL,
    lavmodel. = lavmodel,
    lavsamplestats. = lavsamplestats,
    lavpartable. = lavpartable,
    lavoptions. = lavoptions,
    lavdata. = lavdata,
    R = R,
    check.post = lavoptions$check.post,
    type = boot.type,
    FUN = ifelse(boot.type == "bollen.stine",
      "coeftest", "coef"
    )
  )
  # warn            = -1L)
  COEF.orig <- COEF

  # new in 0.6-12: always warn for failed and nonadmissible
  error.idx <- attr(COEF, "error.idx")
  nfailed <- length(error.idx) # zero if NULL
  if (nfailed > 0L) {
    lav_msg_warn(gettextf(
      "%s bootstrap runs failed or did not converge.", nfailed))
  }

  notok <- length(attr(COEF, "nonadmissible")) # zero if NULL
  if (notok > 0L) {
    lav_msg_warn(gettextf(
      "%s bootstrap runs resulted in nonadmissible solutions.", notok))
  }

  if (length(error.idx) > 0L) {
    # new in 0.6-13: we must still remove them!
    COEF <- COEF[-error.idx, , drop = FALSE]
    # this also drops the attributes
  }

  if (boot.type == "bollen.stine") {
    nc <- ncol(COEF)
    TEST <- COEF[, nc]
    COEF <- COEF[, -nc, drop = FALSE]
  }

  # new in 0.6-20: check for outliers, ie big difference between sd() and mad()
  # see github issue 347
  sd_mad_ratio <- ( apply(COEF, 2,  sd, na.rm = TRUE) /
                    apply(COEF, 2, mad, na.rm = TRUE) )
  crit.ratio <- 5
  if (any(sd_mad_ratio > crit.ratio)) {
    NAMES <- lav_partable_labels(lavpartable, type = "free")
    params_w_outliers <- paste(NAMES[sd_mad_ratio > crit.ratio], collapse = " ")
    lav_msg_warn(gettextf(
      "The following boostrapped free parameters have a high (>5)
      ratio of standard deviation to median absolute deviation: %s.
      P-values and confidence intervals may not match.", params_w_outliers))
  }

  # FIXME: cov rescale? Yes for now
  nboot <- nrow(COEF)
  NVarCov <- lavsamplestats@ntotal * (cov(COEF) * (nboot - 1) / nboot)

  # save COEF and TEST (if any)
  attr(NVarCov, "BOOT.COEF") <- COEF.orig # including attributes
  attr(NVarCov, "BOOT.TEST") <- TEST

  NVarCov
}


# robust `sem' NVCOV (see Browne, 1984,  bentler & dijkstra 1985)
lav_model_nvcov_robust_sem <- function(lavmodel = NULL,
                                       lavsamplestats = NULL,
                                       lavdata = NULL,
                                       lavcache = NULL,
                                       lavimplied = NULL,
                                       lavh1 = NULL,
                                       lavoptions = NULL,
                                       use.ginv = FALSE,
                                       attr.Delta = TRUE,
                                       attr.tDVGVD = FALSE,
                                       attr.E.inv = FALSE,
                                       attr.WLS.V = FALSE) {
  # compute inverse of the expected(!) information matrix
  if (lavmodel@estimator == "ML" && lavoptions$information.expected.mplus) {
    # YR - 11 aug 2010 - what Mplus seems to do is (see Muthen apx 4 eq102)
    # - A1 is not based on Sigma.hat and Mu.hat,
    # but on lavsamplestats@cov and lavsamplestats@mean... ('unstructured')
    # - Gamma is not identical to what is used for WLS; closer to EQS
    # - N/N-1 bug in G11 for NVarCov (but not test statistic)
    # - we divide by N-1! (just like EQS)
    E.inv <- lav_model_information_expected_MLM(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats,
      extra = TRUE,
      augmented = TRUE,
      inverted = TRUE,
      use.ginv = use.ginv
    )
  } else {
    E.inv <- lav_model_information(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats,
      lavdata = lavdata,
      lavimplied = lavimplied,
      lavh1 = lavh1,
      lavoptions = lavoptions,
      extra = TRUE,
      augmented = TRUE,
      inverted = TRUE,
      use.ginv = use.ginv
    )
  }

  # check if E.inv is ok
  if (inherits(E.inv, "try-error")) {
    return(E.inv)
  }

  Delta <- attr(E.inv, "Delta")
  WLS.V <- attr(E.inv, "WLS.V")
  attr(E.inv, "Delta") <- NULL
  attr(E.inv, "WLS.V") <- NULL
  # Gamma
  Gamma <- lavsamplestats@NACOV
  if (lavmodel@estimator == "ML" &&
    lavoptions$gamma.vcov.mplus && !lavsamplestats@NACOV.user) {
    # 'fix' G11 part of Gamma (NOTE: this is NOT needed for SB test
    # statistic
    for (g in 1:lavsamplestats@ngroups) {
      gg1 <- (lavsamplestats@nobs[[g]] - 1) / lavsamplestats@nobs[[g]]
      if (lavmodel@conditional.x) {
        nvar <- NCOL(lavsamplestats@res.cov[[g]])
      } else {
        nvar <- NCOL(lavsamplestats@cov[[g]])
      }
      G11 <- Gamma[[g]][1:nvar, 1:nvar, drop = FALSE]
      Gamma[[g]][1:nvar, 1:nvar] <- G11 * gg1
    } # g
  }


  tDVGVD <- matrix(0, ncol = ncol(E.inv), nrow = nrow(E.inv))
  for (g in 1:lavsamplestats@ngroups) {
    fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal
    if (lavoptions$gamma.vcov.mplus) {
      fg1 <- (lavsamplestats@nobs[[g]] - 1) / lavsamplestats@ntotal
    } else {
      # from 0.6 onwards, we use fg1 == fg, to be more consistent with
      # lav_test()
      fg1 <- fg
    }
    # fg twice for WLS.V, 1/fg1 once for GaMMA
    # if fg==fg1, there would be only one fg, as in Satorra 1999 p.8
    # t(Delta) * WLS.V %*% Gamma %*% WLS.V %*% Delta
    if (lavmodel@estimator == "DWLS" || lavmodel@estimator == "ULS") {
      # diagonal weight matrix
      WD <- WLS.V[[g]] * Delta[[g]]
    } else {
      # full weight matrix
      WD <- WLS.V[[g]] %*% Delta[[g]]
    }
    tDVGVD <- tDVGVD + fg * fg / fg1 * crossprod(WD, Gamma[[g]] %*% WD)
  } # g
  NVarCov <- (E.inv %*% tDVGVD %*% E.inv)

  # to be reused by lav_test()
  if (attr.Delta) {
    attr(NVarCov, "Delta") <- Delta
  }
  # for twostep.robust in sam()
  if (attr.tDVGVD) {
    attr(NVarCov, "tDVGVD") <- tDVGVD
  }

  if ((lavoptions$information[1] == lavoptions$information[2]) &&
    (lavoptions$h1.information[1] == lavoptions$h1.information[2]) &&
    (lavoptions$information[2] == "expected" ||
      lavoptions$observed.information[1] ==
        lavoptions$observed.information[2])) {
    # only when same type of information is used # new in 0.6-6
    attr(NVarCov, "E.inv") <- E.inv
    attr(NVarCov, "WLS.V") <- WLS.V
  }

  # user override
  if (attr.E.inv && is.null(attr(NVarCov, "E.inv"))) {
    attr(NVarCov, "E.inv") <- E.inv
  }
  if (attr.WLS.V && is.null(attr(NVarCov, "WLS.V"))) {
    attr(NVarCov, "WLS.V") <- WLS.V
  }

  NVarCov
}

lav_model_nvcov_robust_sandwich <- function(lavmodel = NULL,
                                            lavsamplestats = NULL,
                                            lavdata = NULL,
                                            lavoptions = NULL,
                                            lavimplied = NULL,
                                            lavh1 = NULL,
                                            lavcache = NULL,
                                            use.ginv = FALSE) {
  # sandwich estimator: A.inv %*% B %*% t(A.inv)
  # where A.inv == E.inv
  #       B == outer product of case-wise scores

  # inverse observed/expected information matrix
  E.inv <- lav_model_information(
    lavmodel = lavmodel,
    lavsamplestats = lavsamplestats,
    lavdata = lavdata,
    lavcache = lavcache,
    lavimplied = lavimplied,
    lavh1 = lavh1,
    lavoptions = lavoptions,
    extra = FALSE,
    augmented = TRUE,
    inverted = TRUE,
    use.ginv = use.ginv
  )

  # check if E.inv is ok
  if (inherits(E.inv, "try-error")) {
    return(E.inv)
  }

  # new in 0.6-6, check for h1.information.meat
  lavoptions2 <- lavoptions
  if (!is.null(lavoptions$information.meat)) {
    lavoptions2$information <- lavoptions$information.meat
  }
  if (!is.null(lavoptions$h1.information.meat)) {
    lavoptions2$h1.information <- lavoptions$h1.information.meat
  }

  # outer product of case-wise scores
  B0 <-
    lav_model_information_firstorder(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats,
      lavdata = lavdata,
      lavcache = lavcache,
      lavimplied = lavimplied,
      lavh1 = lavh1,
      lavoptions = lavoptions2,
      extra = TRUE,
      check.pd = FALSE,
      augmented = FALSE,
      inverted = FALSE,
      use.ginv = use.ginv
    )

  # compute sandwich estimator
  NVarCov <- E.inv %*% B0 %*% E.inv

  attr(NVarCov, "B0.group") <- attr(B0, "B0.group")

  if ((lavoptions$information[1] == lavoptions$information[2]) &&
    (lavoptions$h1.information[1] == lavoptions$h1.information[2]) &&
    (lavoptions$information[2] == "expected" ||
      lavoptions$observed.information[1] ==
        lavoptions$observed.information[2])) {
    # only when same type of information is used # new in 0.6-6
    attr(NVarCov, "E.inv") <- E.inv
  }

  NVarCov
}

# two stage
# - two.stage: Gamma = I_1^{-1}
# - robust.two.stage: Gamma = incomplete Gamma (I_1^{-1} J_1 I_1^{-1})
# where I_1 and J_1 are based on the (saturated) model h1
# (either unstructured, or structured)
#
# references:
#
# - Savalei \& Bentler (2009) eq (6) for se = "two.stage"
# - Savalei \& Falk (2014) eq  (3)   for se = "robust.two.stage"
# - Yuan \& Bentler (2000)
lav_model_nvcov_two_stage <- function(lavmodel = NULL,
                                      lavsamplestats = NULL,
                                      lavoptions = NULL,
                                      lavimplied = NULL,
                                      lavh1 = NULL,
                                      lavdata = NULL,
                                      use.ginv = FALSE) {
  # expected OR observed, depending on lavoptions$information
  if (is.null(lavoptions) && is.null(lavoptions$information[1])) {
    lavoptions <- list(
      information = "observed",
      observed.information = "h1",
      h1.information = "structured"
    )
  }

  # restrictions:
  # only works if:
  # - information is expected,
  # - or information is observed but with observed.information == "h1"
  if (lavoptions$information[1] == "observed" &&
    lavoptions$observed.information[1] != "h1") {
    lav_msg_stop(
      gettext("two.stage + observed information currently only works
              with observed.information = 'h1'"))
  }
  # no weights (yet)
  if (!is.null(lavdata@weights[[1]])) {
    lav_msg_stop(gettext("two.stage + sampling.weights is not supported yet"))
  }
  # no fixed.x (yet)
  # if(!is.null(lavsamplestats@x.idx) &&
  #   length(lavsamplestats@x.idx[[1]]) > 0L) {
  #    lav_msg_stop(gettext("two.stage + fixed.x = TRUE is not supported yet"))
  # }


  # information matrix
  E.inv <- lav_model_information(
    lavmodel = lavmodel,
    lavsamplestats = lavsamplestats,
    lavdata = lavdata,
    lavoptions = lavoptions,
    lavimplied = lavimplied,
    lavh1 = lavh1,
    extra = TRUE,
    augmented = TRUE,
    inverted = TRUE,
    use.ginv = use.ginv
  )
  Delta <- attr(E.inv, "Delta")
  WLS.V <- attr(E.inv, "WLS.V") # this is 'H' or 'A1' in the literature
  attr(E.inv, "Delta") <- NULL
  attr(E.inv, "WLS.V") <- NULL

  # check if E.inv is ok
  if (inherits(E.inv, "try-error")) {
    return(E.inv)
  }

  # check WLS.V = A1
  if (is.null(WLS.V)) {
    lav_msg_stop(gettext("WLS.V/H/A1 is NULL, observed.information = hessian?"))
  }

  # Gamma
  Gamma <- vector("list", length = lavsamplestats@ngroups)

  # handle multiple groups
  tDVGVD <- matrix(0, ncol = ncol(E.inv), nrow = nrow(E.inv))
  for (g in 1:lavsamplestats@ngroups) {
    fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal
    # fg1 <- (lavsamplestats@nobs[[g]]-1)/lavsamplestats@ntotal
    fg1 <- fg
    # fg twice for WLS.V, 1/fg1 once for GaMMA
    # if fg==fg1, there would be only one fg, as in Satorra 1999 p.8
    # t(Delta) * WLS.V %*% Gamma %*% WLS.V %*% Delta
    WD <- WLS.V[[g]] %*% Delta[[g]]

    # to compute (incomplete) GAMMA, should we use
    # structured or unstructured mean/sigma?
    #
    # we use the same setting as to compute 'H' (the h1 information matrix)
    # so that at Omega = H if data is complete
    if (lavoptions$h1.information[1] == "unstructured") {
      #MU <- lavsamplestats@missing.h1[[g]]$mu
      #SIGMA <- lavsamplestats@missing.h1[[g]]$sigma
      MU <- lavh1$implied$mean[[g]]
      SIGMA <- lavh1$implied$cov[[g]]
    } else {
      MU <- lavimplied$mean[[g]]
      SIGMA <- lavimplied$cov[[g]]
    }

    # compute 'Gamma' (or Omega.beta)
    if (lavoptions$se == "two.stage") {
      # this is Savalei & Bentler (2009)
      if (lavoptions$information[1] == "expected") {
        Info <- lav_mvnorm_missing_information_expected(
          Y = lavdata@X[[g]], Mp = lavdata@Mp[[g]],
          wt = lavdata@weights[[g]],
          Mu = MU, Sigma = SIGMA,
          x.idx = lavsamplestats@x.idx[[g]]
        )
      } else {
        Info <- lav_mvnorm_missing_information_observed_samplestats(
          Yp = lavsamplestats@missing[[g]],
          # wt not needed
          Mu = MU, Sigma = SIGMA,
          x.idx = lavsamplestats@x.idx[[g]]
        )
      }
      Gamma[[g]] <- lav_matrix_symmetric_inverse(Info)
    } else { # we assume "robust.two.stage"
      # NACOV is here incomplete Gamma
      # Savalei & Falk (2014)
      #
      if (length(lavdata@cluster) > 0L) {
        cluster.idx <- lavdata@Lp[[g]]$cluster.idx[[2]]
      } else {
        cluster.idx <- NULL
      }
      Gamma[[g]] <- lav_mvnorm_missing_h1_omega_sw(
        Y =
          lavdata@X[[g]], Mp = lavdata@Mp[[g]],
        Yp = lavsamplestats@missing[[g]],
        wt = lavdata@weights[[g]],
        cluster.idx = cluster.idx,
        Mu = MU, Sigma = SIGMA,
        x.idx = lavsamplestats@x.idx[[g]],
        information = lavoptions$information[1]
      )
    }

    # compute
    tDVGVD <- tDVGVD + fg * fg / fg1 * crossprod(WD, Gamma[[g]] %*% WD)
  } # g

  NVarCov <- (E.inv %*% tDVGVD %*% E.inv)

  # to be reused by lavaanTest
  attr(NVarCov, "Delta") <- Delta
  attr(NVarCov, "Gamma") <- Gamma
  if ((lavoptions$information[1] == lavoptions$information[2]) &&
    (lavoptions$h1.information[1] == lavoptions$h1.information[2]) &&
    (lavoptions$information[2] == "expected" ||
      lavoptions$observed.information[1] ==
        lavoptions$observed.information[2])) {
    # only when same type of information is used # new in 0.6-6
    attr(NVarCov, "E.inv") <- E.inv
    attr(NVarCov, "WLS.V") <- WLS.V
  }

  NVarCov
}



lav_model_vcov <- function(lavmodel = NULL,
                           lavsamplestats = NULL,
                           lavoptions = NULL,
                           lavdata = NULL,
                           lavpartable = NULL,
                           lavcache = NULL,
                           lavimplied = NULL,
                           lavh1 = NULL,
                           use.ginv = FALSE) {
  likelihood <- lavoptions$likelihood
#  information <- lavoptions$information[1] # first one is for vcov
  se <- lavoptions$se
#  mimic <- lavoptions$mimic

  # special cases
  if (se == "none" || se == "external" || se == "twostep") {
    return(matrix(0, 0, 0))
  }

  if (se == "standard") {
    NVarCov <- lav_model_information(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats,
      lavdata = lavdata,
      lavcache = lavcache,
      lavimplied = lavimplied,
      lavh1 = lavh1,
      lavoptions = lavoptions,
      extra = FALSE,
      augmented = TRUE,
      inverted = TRUE,
      use.ginv = use.ginv
    )
  } else if (se == "first.order") {
    NVarCov <-
      lav_model_information_firstorder(
        lavmodel = lavmodel,
        lavsamplestats = lavsamplestats,
        lavdata = lavdata,
        lavcache = lavcache,
        lavimplied = lavimplied,
        lavh1 = lavh1,
        lavoptions = lavoptions,
        extra = TRUE,
        check.pd = FALSE,
        augmented = TRUE,
        inverted = TRUE,
        use.ginv = use.ginv
      )
  } else if (se %in% c("robust.sem", "robust.sem.nt", "robust.cluster.sem")) {
    NVarCov <-
      lav_model_nvcov_robust_sem(
        lavmodel = lavmodel,
        lavsamplestats = lavsamplestats,
        lavcache = lavcache,
        lavdata = lavdata,
        lavimplied = lavimplied,
        lavh1 = lavh1,
        lavoptions = lavoptions,
        use.ginv = use.ginv
      )
  } else if (se == "robust.huber.white" || se == "robust.cluster") {
    NVarCov <-
      lav_model_nvcov_robust_sandwich(
        lavmodel = lavmodel,
        lavsamplestats = lavsamplestats,
        lavdata = lavdata,
        lavcache = lavcache,
        lavimplied = lavimplied,
        lavh1 = lavh1,
        lavoptions = lavoptions,
        use.ginv = use.ginv
      )
  } else if (se %in% c("two.stage", "robust.two.stage")) {
    NVarCov <-
      lav_model_nvcov_two_stage(
        lavmodel = lavmodel,
        lavsamplestats = lavsamplestats,
        lavoptions = lavoptions,
        lavdata = lavdata,
        lavimplied = lavimplied,
        lavh1 = lavh1,
        use.ginv = use.ginv
      )
  } else if (se == "bootstrap") {
    NVarCov <- try(
      lav_model_nvcov_bootstrap(
        lavmodel = lavmodel,
        lavsamplestats = lavsamplestats,
        lavoptions = lavoptions,
        lavdata = lavdata,
        lavimplied = lavimplied,
        lavh1 = lavh1,
        lavcache = lavcache,
        lavpartable = lavpartable
      ),
      silent = TRUE
    )
  } else {
    lav_msg_warn(gettextf("unknown se type: %s", se))
  }

  if (!inherits(NVarCov, "try-error")) {
    # denominator!
    if (lavmodel@estimator %in% c("ML", "PML", "FML") &&
      likelihood == "normal") {
      if (lavdata@nlevels == 1L) {
        N <- lavsamplestats@ntotal
        # new in 0.6-9 (to mimic method="lm" in effectLite)
        # special case: univariate regression in each group
        if (lavoptions$mimic == "lm" &&
          all(lavmodel@modprop$uvreg)) {
          N <- sum(unlist(lavsamplestats@nobs) -
            (unlist(lavmodel@modprop$nexo) + 1L))
          # always adding the intercept (for now)
        }
      } else {
        # total number of clusters (over groups)
        N <- 0
        for (g in 1:lavsamplestats@ngroups) {
          N <- N + lavdata@Lp[[g]]$nclusters[[2]]
        }
      }
    } else {
      N <- lavsamplestats@ntotal - lavsamplestats@ngroups
    }

    VarCov <- 1 / N * NVarCov

    # check if VarCov is pd -- new in 0.6-2
    # mostly important if we have (in)equality constraints (MASS::ginv!)
    if (lavmodel@ceq.simple.only) {
      # do nothing
    } else if (!is.null(lavoptions$check.vcov) && lavoptions$check.vcov) {
      eigvals <- eigen(VarCov,
        symmetric = TRUE,
        only.values = TRUE
      )$values
      # correct for (in)equality constraints
      neq <- 0L
      niq <- 0L
      if (nrow(lavmodel@con.jac) > 0L) {
        ceq.idx <- attr(lavmodel@con.jac, "ceq.idx")
        cin.idx <- attr(lavmodel@con.jac, "cin.idx")
        ina.idx <- attr(lavmodel@con.jac, "inactive.idx")
        if (length(ceq.idx) > 0L) {
          neq <- qr(lavmodel@con.jac[ceq.idx, , drop = FALSE])$rank
        }
        if (length(cin.idx) > 0L) {
          niq <- length(cin.idx) - length(ina.idx) # only active
        }
        # total number of relevant constraints
        neiq <- neq + niq
        if (neiq > 0L) {
          eigvals <- rev(eigvals)[-seq_len(neiq)]
        }
      }
      min.val <- min(eigvals)
      # if(any(eigvals < -1 * sqrt(.Machine$double.eps)) &&
      if (min.val < .Machine$double.eps^(3 / 4)) {
        # VarCov.chol <- suppressWarnings(try(chol(VarCov,
        #                   pivot = TRUE), silent = TRUE))
        # VarCov.rank <- attr(VarCov.chol, "rank")
        # VarCov.pivot <- attr(VarCov.chol, "pivot")
        # VarCov.badidx <- VarCov.pivot[ VarCov.rank + 1L ]
        # pt.idx <- which(lavpartable$free == VarCov.badidx)
        # par.string <- paste(lavpartable$lhs[pt.idx],
        #                    lavpartable$op[ pt.idx],
        #                    lavpartable$rhs[pt.idx])
        # if(lavdata@ngroups > 1L) {
        #    par.string <- paste0(par.string, " in group ",
        #                         lavpartable$group[pt.idx])
        # }
        # if(lavdata@nlevels > 1L) {
        #    par.string <- paste0(par.string, " in level ",
        #                         lavpartable$level[pt.idx])
        # }

        if (min.val > 0) {
          lav_msg_warn(
            gettextf("The variance-covariance matrix of the estimated
                    parameters (vcov) does not appear to be positive
                    definite! The smallest eigenvalue (= %e) is close
                     to zero. This may be a symptom that the model is
                     not identified.", min(min.val)))
        } else {
          lav_msg_warn(
            gettextf("The variance-covariance matrix of the estimated parameters
                     (vcov) does not appear to be positive definite! The smallest
                     eigenvalue (= %e) is smaller than zero. This may be a
                     symptom that the model is not identified.",
                     min(min.val)))
        }
      }
    }
  } else {
    lav_msg_warn(
     gettext("Could not compute standard errors! The information matrix
             could not be inverted. This may be a symptom that the model
             is not identified.")
    )
    VarCov <- NULL
  } # could not invert

  VarCov
}

lav_model_vcov_se <- function(lavmodel, lavpartable, VCOV = NULL,
                              BOOT = NULL) {
  # 0. special case
  if (is.null(VCOV)) {
    se <- rep(as.numeric(NA), lavmodel@nx.user)
    se[lavpartable$free == 0L] <- 0.0
    return(se)
  }

  # 1. free parameters only
  x.var <- diag(VCOV)
  # check for negative values (what to do: NA or 0.0?)
  x.var[x.var < 0] <- as.numeric(NA)
  x.se <- sqrt(x.var)
  if (lavmodel@ceq.simple.only) {
    GLIST <- lav_model_x2glist(
      lavmodel = lavmodel, x = x.se,
      type = "unco"
    )
  } else {
    GLIST <- lav_model_x2glist(
      lavmodel = lavmodel, x = x.se,
      type = "free"
    )
  }

  # se for full parameter table, but with 0.0 entries for def/ceq/cin
  # elements
  se <- lav_model_get_parameters(
    lavmodel = lavmodel, GLIST = GLIST,
    type = "user", extra = FALSE
  )


  # 2. fixed parameters -> se = 0.0
  se[which(lavpartable$free == 0L)] <- 0.0


  # 3. defined parameters:
  def.idx <- which(lavpartable$op == ":=")
  if (length(def.idx) > 0L) {
    if (!is.null(BOOT)) {
      # we must remove the NA rows (and hope we have something left)
      error.idx <- attr(BOOT, "error.idx")
      if (length(error.idx) > 0L) {
        BOOT <- BOOT[-error.idx, , drop = FALSE] # drops attributes
      }

      BOOT.def <- apply(BOOT, 1L, lavmodel@def.function)
      if (length(def.idx) == 1L) {
        BOOT.def <- as.matrix(BOOT.def)
      } else {
        BOOT.def <- t(BOOT.def)
      }
      # new in 0.6-20: check for outliers, big difference betwen sd() and mad()
      # see github issue 347
      sd_mad_ratio <- ( apply(BOOT.def, 2,  sd, na.rm = TRUE) /
                        apply(BOOT.def, 2, mad, na.rm = TRUE) )
      crit.ratio <- 5
      if (any(sd_mad_ratio > crit.ratio)) {
        NAMES <- colnames(BOOT.def)
        def_w_outliers <- paste(NAMES[sd_mad_ratio > crit.ratio],
                                collapse = " ")
        lav_msg_warn(gettextf(
          "The following boostrapped defined parameters have a high (>5)
          ratio of standard deviation to median absolute deviation: %s.
          P-values and confidence intervals may not match.", def_w_outliers))
      }
      nboot <- nrow(BOOT.def)
      def.cov <- cov(BOOT.def) * (nboot - 1) / nboot
    } else {
      # regular delta method
      x <- lav_model_get_parameters(lavmodel = lavmodel, type = "free")
      JAC <- try(lav_func_jacobian_complex(func = lavmodel@def.function, x = x),
        silent = TRUE
      )
      if (inherits(JAC, "try-error")) { # eg. pnorm()
        JAC <- lav_func_jacobian_simple(func = lavmodel@def.function, x = x)
      }
      if (lavmodel@ceq.simple.only) {
        JAC <- JAC %*% t(lavmodel@ceq.simple.K)
      }
      def.cov <- JAC %*% VCOV %*% t(JAC)
    }
    # check for negative se's
    diag.def.cov <- diag(def.cov)
    diag.def.cov[diag.def.cov < 0] <- as.numeric(NA)
    se[def.idx] <- sqrt(diag.def.cov)
  }

  se
}

# numerical derivatives using complex numbers
# see Squire & Trapp 1998, siam rev 40(1) 110-112
# or Ridout, MS (2009), the american statistician 63(1) 66-74

# it would seem that you can choose h to be fairly small, without
# sacrifycing accuracy due to rounding errors

# YR 17 July 2012

lav_func_gradient_complex <- function(func, x,
                                      h = .Machine$double.eps, ...,
                                      fallback.simple = TRUE) {
  f0 <- try(func(x * (0 + 1i), ...), silent = TRUE)
  if (!is.complex(f0)) {
    if (fallback.simple) {
      dx <- lav_func_gradient_simple(func = func, x = x, h = sqrt(h), ...)
      return(dx)
    } else {
      lav_msg_stop(gettext(
        "function does not return a complex value")) # eg abs()
    }
  }
  if (inherits(f0, "try-error")) {
    if (fallback.simple) {
      dx <- lav_func_gradient_simple(func = func, x = x, h = sqrt(h), ...)
      return(dx)
    } else {
      lav_msg_stop(gettext(
        "function does not support non-numeric (complex) argument"))
    }
  }
  if (length(f0) != 1L) {
    lav_msg_stop(gettext(
      "function is not scalar and returns more than one element"))
  }

  nvar <- length(x)

  # determine 'h' per element of x
  h <- pmax(h, abs(h * x))

  # get exact h, per x
  tmp <- x + h
  h <- (tmp - x)

  # simple 'forward' method
  dx <- rep(as.numeric(NA), nvar)
  for (p in seq_len(nvar)) {
    dx[p] <- Im(func(x + h * 1i * (seq.int(nvar) == p), ...)) / h[p]
  }

  dx
}

# as a backup, if func() is not happy about non-numeric arguments
lav_func_gradient_simple <- function(func, x,
                                     h = sqrt(.Machine$double.eps), ...) {
  # check current point, see if it is a scalar function
  f0 <- func(x, ...)
  if (length(f0) != 1L) {
    lav_msg_stop(gettext(
      "function is not scalar and returns more than one element"))
  }

  nvar <- length(x)

  # determine 'h' per element of x
  h <- pmax(h, abs(h * x))

  # get exact h, per x
  tmp <- x + h
  h <- (tmp - x)

  # simple 'forward' method
  dx <- rep(as.numeric(NA), nvar)
  for (p in seq_len(nvar)) {
    dx[p] <- (func(x + h * (seq.int(nvar) == p), ...) - func(x, ...)) / h[p]
  }

  dx
}

lav_func_jacobian_complex <- function(func, x,
                                      h = .Machine$double.eps, ...,
                                      fallback.simple = TRUE) {
  f0 <- try(func(x * (0 + 1i), ...), silent = TRUE)
  if (!is.complex(f0)) {
    if (fallback.simple) {
      dx <- lav_func_jacobian_simple(func = func, x = x, h = sqrt(h), ...)
      return(dx)
    } else {
      lav_msg_stop(gettext(
        "function does not return a complex value")) # eg abs()
    }
  }
  if (inherits(f0, "try-error")) {
    if (fallback.simple) {
      dx <- lav_func_jacobian_simple(func = func, x = x, h = sqrt(h), ...)
      return(dx)
    } else {
      lav_msg_stop(gettext(
        "function does not support non-numeric (complex) argument"))
    }
  }
  nres <- length(f0)
  nvar <- length(x)

  # determine 'h' per element of x
  h <- pmax(h, abs(h * x))

  # get exact h, per x
  tmp <- x + h
  h <- (tmp - x)

  # simple 'forward' method
  dx <- matrix(as.numeric(NA), nres, nvar)
  for (p in seq_len(nvar)) {
    dx[, p] <- Im(func(x + h * 1i * (seq.int(nvar) == p), ...)) / h[p]
  }

  dx
}

lav_func_jacobian_simple <- function(func, x,
                                     h = sqrt(.Machine$double.eps), ...) {
  f0 <- func(x, ...)
  nres <- length(f0)
  nvar <- length(x)

  # determine 'h' per element of x
  h <- pmax(h, abs(h * x))

  # get exact h, per x
  tmp <- x + h
  h <- (tmp - x)

  # simple 'forward' method
  dx <- matrix(as.numeric(NA), nres, nvar)
  for (p in seq_len(nvar)) {
    dx[, p] <- (func(x + h * (seq.int(nvar) == p), ...) - func(x, ...)) / h[p]
  }

  dx
}

# this is based on the Ridout (2009) paper, and the code snippet for 'h4'
lav_func_hessian_complex <- function(func, x,
                                     h = .Machine$double.eps, ...) {
  f0 <- try(func(x * (0 + 1i), ...), silent = TRUE)
  if (!is.complex(f0)) {
    lav_msg_stop(gettext(
      "function does not return a complex value")) # eg abs()
  }
  if (inherits(f0, "try-error")) {
    lav_msg_stop(gettext(
      "function does not support non-numeric (complex) argument"))
  }
  if (length(f0) != 1L) {
    lav_msg_stop(gettext(
      "function is not scalar and returns more than one element"))
  }

  nvar <- length(x)

  # determine 'h' per element of x
  # delta1 <- pmax(h^(1/3), abs(h^(1/3)*x))
  # delta2 <- pmax(h^(1/5), abs(h^(1/5)*x))
  delta1 <- h^(1 / 3)
  delta2 <- h^(1 / 5)

  H <- matrix(as.numeric(NA), nvar, nvar)
  for (i in seq_len(nvar)) {
    for (j in 1:i) {
      if (i == j) {
        delta <- delta2
      } else {
        delta <- delta1
      }
      H[i, j] <- H[j, i] <-
        Im(func(x + delta * 1i * (seq.int(nvar) == i) * x +
          delta * (seq.int(nvar) == j) * x, ...) -
          func(x + delta * 1i * (seq.int(nvar) == i) * x -
            delta * (seq.int(nvar) == j) * x, ...)) /
          (2 * delta * delta * x[i] * x[j])
    }
  }

  H
}

lav_deriv_cov2corB <- function(COV = NULL) {
  nvar <- nrow(COV)
  dS.inv <- 1 / diag(COV)
  R <- cov2cor(COV)
  A <- -R %x% (0.5 * diag(dS.inv))
  B <- (0.5 * diag(dS.inv)) %x% -R
  DD <- diag(lav_matrix_vec(diag(nvar)))
  A2 <- A %*% DD
  B2 <- B %*% DD
  out <- A2 + B2 + diag(lav_matrix_vec(tcrossprod(sqrt(dS.inv))))
  D <- lav_matrix_duplication(nvar)
  out.vech <- 0.5 * (t(D) %*% out %*% D)
  out.vech
}

# quick and dirty (FIXME!!!) way to get
# surely there must be a more elegant way?
# see lav_deriv_cov2corB, if no num.idx...
# dCor/dCov
lav_deriv_cov2cor <- function(COV = NULL, num.idx = NULL) {
  # dCor/dvar1 = - cov / (2*var1 * sqrt(var1) * sqrt(var2))
  # dCor/dvar2 = - cov / (2*var2 * sqrt(var1) * sqrt(var2))
  # dCor/dcov  =  1/(sqrt(var1) * sqrt(var2))

  # diagonal: diag(lav_matrix_vech(tcrossprod(1/delta)))

  nvar <- ncol(COV)
  pstar <- nvar * (nvar + 1) / 2
  delta <- sqrt(diag(COV))
  if (length(num.idx) > 0L) {
    delta[num.idx] <- 1.0
  }

  A <- COV * -1 / (2 * delta * delta * tcrossprod(delta))
  if (length(num.idx) > 0L) {
    A[num.idx, ] <- 0
    A[cbind(num.idx, num.idx)] <- 1
  }
  A2 <- diag(nvar) %x% t(A)

  OUT <- diag(pstar)
  diag(OUT) <- lav_matrix_vech(tcrossprod(1 / delta))
  var.idx <- lav_matrix_diagh_idx(nvar)
  DUP <- lav_matrix_duplication(nvar)
  OUT[, var.idx] <- t(DUP) %*% A2[, lav_matrix_diag_idx(nvar)]

  if (length(num.idx) > 0L) {
    var.idx <- var.idx[-num.idx]
  }
  OUT[var.idx, var.idx] <- 0

  OUT
}


lav_deriv_cov2cor_numerical <- function(COV, num.idx = integer(0)) {
  compute.R <- function(x) {
    S <- lav_matrix_vech_reverse(x)
    diagS <- diag(S)
    delta <- 1 / sqrt(diagS)
    if (length(num.idx) > 0L) {
      delta[num.idx] <- 1.0
    }
    R <- diag(delta) %*% S %*% diag(delta)
    # R <- cov2cor(S)
    R.vec <- lav_matrix_vech(R, diagonal = TRUE)
    R.vec
  }

  x <- lav_matrix_vech(COV, diagonal = TRUE)
  dx <- lav_func_jacobian_complex(func = compute.R, x = x)

  dx
}

# create random starting values starting from a parameter table
# - using the lower/upper bounds and runif() for factor loadings
#   and variances
# - using runif(,-1,+1) for correlations; rescale using variances
# - check if Sigma.hat is PD; if not, try again
#
# YR 26 Feb 2024

lav_partable_random <- function(lavpartable = NULL,
                                # needed if we still need to compute bounds:
                                lavh1 = NULL, lavdata = NULL,
                                lavsamplestats = NULL, lavoptions = NULL) {

  lavpta <- lav_partable_attributes(lavpartable)

  # ALWAYS (recompute) bounds, as user may have provide other
  # bounds (eg "pos.var") (0.6-20)
  lavoptions2 <- lavoptions
  lavoptions2$bounds <- "standard"
  lavoptions2$optim.bounds <-
    list(
      lower = c(
        "ov.var", "lv.var", "loadings",
        "covariances"
      ),
      upper = c(
        "ov.var", "lv.var", "loadings",
        "covariances"
      ),
      lower.factor = c(1.0, 1.0, 1.0, 0.999),
      upper.factor = c(1.0, 1.0, 1.0, 0.999),
      min.reliability.marker = 0.1,
      min.var.lv.endo = 0.005
    )
  lavpartable <- lav_partable_add_bounds(
    partable = lavpartable,
    lavh1 = lavh1, lavdata = lavdata,
    lavsamplestats = lavsamplestats, lavoptions = lavoptions2
  )

  # replace -Inf/Inf by -1/1 * .Machine$double.eps (for runif)
  inf.idx <- which(lavpartable$lower < -1e+16)
  if (length(inf.idx) > 0L) {
    lavpartable$lower[inf.idx] <- -1e+16
  }
  inf.idx <- which(lavpartable$upper > 1e+16)
  if (length(inf.idx) > 0L) {
    lavpartable$upper[inf.idx] <- 1e+16
  }

  # empty lavpartable$start?
  if (is.null(lavpartable$start)) {
    START <- numeric(length(lavpartable$lhs))
    # set loadings to 0.7
    loadings.idx <- which(lavpartable$free > 0L &
      lavpartable$op == "=~")
    if (length(loadings.idx) > 0L) {
      START[loadings.idx] <- 0.7
    }
    # set (only) variances to 1
    var.idx <- which(lavpartable$free > 0L &
      lavpartable$op == "~~" &
      lavpartable$lhs == lavpartable$rhs)
    if (length(var.idx) > 0L) {
      START[var.idx] <- 1
    }

    lavpartable$start <- START
  }

  # initial values
  START <- lavpartable$start

  nblocks <- lav_partable_nblocks(lavpartable)
  block.values <- lav_partable_block_values(lavpartable)
  for (b in 1:nblocks) {
    ov.names <- lavpta$vnames$ov[[b]]
    lv.names <- lavpta$vnames$lv[[b]]
    ov.ind.names <- lavpta$vnames$ov.ind[[b]]

    # start with the lv (residual) variances
    lv.var.idx <- which(lavpartable$block == block.values[b] &
      lavpartable$op == "~~" &
      lavpartable$lhs %in% lv.names &
      lavpartable$rhs %in% lv.names &
      lavpartable$lhs == lavpartable$rhs)

    if (length(lv.var.idx) > 0L) {
      for (i in lv.var.idx) {
        if (lavpartable$free[i] > 0L &&
          (lavpartable$lower[i] < lavpartable$upper[i])) {
          START[i] <- runif(
            n = 1L, min = lavpartable$lower[i],
            max = lavpartable$upper[i]
          )
        }
      }
    }

    # first, we generate lv correlations, and then rescale to covariances
    lv.cov.idx <- which(lavpartable$block == block.values[b] &
      lavpartable$op == "~~" &
      lavpartable$lhs %in% lv.names &
      lavpartable$rhs %in% lv.names &
      lavpartable$lhs != lavpartable$rhs)

    if (length(lv.cov.idx) > 0L) {
      for (i in lv.cov.idx) {
        if (lavpartable$free[i] > 0L &&
          (lavpartable$lower[i] < lavpartable$upper[i])) {
          cor.val <- runif(n = 1L, -0.5, +0.5)
          var1.idx <- which(lavpartable$block == block.values[b] &
            lavpartable$op == "~~" &
            lavpartable$lhs == lavpartable$lhs[i] &
            lavpartable$lhs == lavpartable$rhs)
          var2.idx <- which(lavpartable$block == block.values[b] &
            lavpartable$op == "~~" &
            lavpartable$lhs == lavpartable$rhs[i] &
            lavpartable$lhs == lavpartable$rhs)
          START[i] <- cor.val * sqrt(START[var1.idx]) * sqrt(START[var2.idx])
        }
      }
    }

    # next, (residual) ov variances
    ov.var.idx <- which(lavpartable$block == block.values[b] &
      lavpartable$op == "~~" &
      lavpartable$lhs %in% ov.names &
      lavpartable$rhs %in% ov.names &
      lavpartable$lhs == lavpartable$rhs)

    if (length(ov.var.idx) > 0L) {
      for (i in ov.var.idx) {
        if (lavpartable$free[i] > 0L &&
          (lavpartable$lower[i] < lavpartable$upper[i])) {
          START[i] <- runif(
            n = 1L, min = lavpartable$lower[i],
            max = lavpartable$upper[i]
          )
        }
      }
    }

    # (residual) ov covariances (if any)
    ov.cov.idx <- which(lavpartable$block == block.values[b] &
      lavpartable$op == "~~" &
      lavpartable$lhs %in% ov.names &
      lavpartable$rhs %in% ov.names &
      lavpartable$lhs != lavpartable$rhs)

    if (length(ov.cov.idx) > 0L) {
      for (i in ov.cov.idx) {
        if (lavpartable$free[i] > 0L &&
          (lavpartable$lower[i] < lavpartable$upper[i])) {
          cor.val <- runif(n = 1L, -0.5, +0.5)
          var1.idx <- which(lavpartable$block == block.values[b] &
            lavpartable$op == "~~" &
            lavpartable$lhs == lavpartable$lhs[i] &
            lavpartable$lhs == lavpartable$rhs)
          var2.idx <- which(lavpartable$block == block.values[b] &
            lavpartable$op == "~~" &
            lavpartable$lhs == lavpartable$rhs[i] &
            lavpartable$lhs == lavpartable$rhs)
          START[i] <- cor.val * sqrt(START[var1.idx]) * sqrt(START[var2.idx])
        }
      }
    }

    # finally, the lambda values, keeping in mind that
    # lambda_p^(u) = sqrt( upper(res.var.indicators_p) /
    #                      lower(var.factor) )
    lambda.idx <- which(lavpartable$block == block.values[b] &
      lavpartable$op == "=~" &
      lavpartable$lhs %in% lv.names &
      lavpartable$rhs %in% ov.ind.names)

    if (length(lambda.idx)) {
      for (i in lambda.idx) {
        if (lavpartable$free[i] > 0L &&
          (lavpartable$lower[i] < lavpartable$upper[i])) {
          varov.idx <- which(lavpartable$block == block.values[b] &
            lavpartable$op == "~~" &
            lavpartable$lhs == lavpartable$rhs[i] &
            lavpartable$lhs == lavpartable$rhs)
          varlv.idx <- which(lavpartable$block == block.values[b] &
            lavpartable$op == "~~" &
            lavpartable$lhs == lavpartable$lhs[i] &
            lavpartable$lhs == lavpartable$rhs)
          lambda.u <- sqrt(START[varov.idx] / START[varlv.idx])
          START[i] <- runif(n = 1, -lambda.u, lambda.u)
        }
      }
    }
  }

  # sanity check; needed?
  current.warn <- lav_warn()
  if (lav_warn(TRUE))
      on.exit(lav_warn(current.warn), TRUE)
  START <- lav_start_check_cov(
    lavpartable = lavpartable, start = START
  )

  START
}

# compute the jacobian: dtheta_2/dtheta_1:
#
# theta_2: - in the rows
#          - the croon corrections, expressed as
#              1) scaled offsets (scoffset), and
#              2) scaling factors
# theta_1: - in the columns
#          - the free parameters of the measurement model
#
lav_fsr_delta21 <- function(object, FSM = NULL) {
  lavmodel <- object@Model
  nmat <- lavmodel@nmat

  NCOL <- lavmodel@nx.free
  m.el.idx <- x.el.idx <- vector("list", length = length(lavmodel@GLIST))
  for (mm in seq_len(length(lavmodel@GLIST))) {
    m.el.idx[[mm]] <- lavmodel@m.free.idx[[mm]]
    x.el.idx[[mm]] <- lavmodel@x.free.idx[[mm]]
    # handle symmetric matrices
    if (lavmodel@isSymmetric[mm]) {
      # since we use 'x.free.idx', only symmetric elements
      # are duplicated (not the equal ones, only in x.free.free)
      dix <- duplicated(x.el.idx[[mm]])
      if (any(dix)) {
        m.el.idx[[mm]] <- m.el.idx[[mm]][!dix]
        x.el.idx[[mm]] <- x.el.idx[[mm]][!dix]
      }
    }
  }

  # Delta per group (or block?)
  Delta <- vector("list", length = lavmodel@ngroups)

  for (g in 1:lavmodel@ngroups) {
    fsm <- FSM[[g]]

    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- lavmodel@GLIST[mm.in.group]

    nrow.scoffset <- ncol(MLIST$lambda)
    nrow.scale <- ncol(MLIST$lambda)
    NROW <- nrow.scoffset + nrow.scale
    Delta.group <- matrix(0, nrow = NROW, ncol = NCOL)

    # prepare some computations
    AL.inv <- solve(fsm %*% MLIST$lambda)
    ATA <- fsm %*% MLIST$theta %*% t(fsm)

    for (mm in mm.in.group) {
      mname <- names(lavmodel@GLIST)[mm]

      # skip empty ones
      if (!length(m.el.idx[[mm]])) next

      if (mname == "lambda") {
        dL <- (-1 * (ATA %*% AL.inv + AL.inv %*% ATA) %*%
          (AL.inv %x% AL.inv) %*% fsm)

        delta.scoffset <- dL
        delta.scale <- fsm ## only ok for 1 row!!!
        delta <- rbind(delta.scoffset, delta.scale)

        Delta.group[, x.el.idx[[mm]]] <- delta[, m.el.idx[[mm]]]
      } else if (mname == "theta") {
        dT <- lav_matrix_vec((t(AL.inv) %*% fsm) %x%
          (t(fsm) %*% AL.inv))
        delta.scoffset <- dT
        delta.scale <- matrix(0,
          nrow = nrow.scale,
          ncol = length(MLIST$theta)
        )
        delta <- rbind(delta.scoffset, delta.scale)

        Delta.group[, x.el.idx[[mm]]] <- delta[, m.el.idx[[mm]]]
      } else if (mname %in% c("psi", "nu", "alpha")) {
        # zero
        next
      } else {
        lav_msg_stop(gettextf(
          "model matrix %s is not lambda/theta/psi", mname))
      }
    } # mm

    Delta[[g]] <- Delta.group
  } # g

  Delta
}

lav_fsr_pa2si <- function(PT = NULL, LVINFO) {
  PT.orig <- PT

  # remove se column (if any)
  if (!is.null(PT$se)) {
    PT$se <- NULL
  }

  # ngroups
  ngroups <- lav_partable_ngroups(PT)

  lhs <- rhs <- op <- character(0)
  group <- block <- level <- free <- exo <- integer(0)
  ustart <- est <- start <- numeric(0)

  for (g in seq_len(ngroups)) {
    nMM <- length(LVINFO[[g]])
    for (mm in seq_len(nMM)) {
      lvinfo <- LVINFO[[g]][[mm]]
      lv.names <- lvinfo$lv.names

      nfac <- length(lv.names)
      if (nfac > 1L) {
        lav_msg_stop(gettext("more than 1 factor in measurement block"))
      }

      LV <- lv.names
      ind <- paste(LV, ".si", sep = "")
      scoffset <- lvinfo$scoffset[1, 1]
      scale <- lvinfo$scale[1, 1]

      lhs <- c(lhs, LV, ind, ind, ind)
      op <- c(op, "=~", "~~", "~*~", "~1")
      rhs <- c(rhs, ind, ind, ind, "")
      block <- c(block, rep(g, 4L))
      free <- c(free, 0L, 1L, 1L, 0L)
      ustart <- c(ustart, 1, scoffset, scale, 0)
      exo <- c(exo, rep(0L, 4L))
      group <- c(group, rep(g, 4L))
      start <- c(start, 1, scoffset, scale, 0)
      est <- c(est, 1, scoffset, scale, 0)
    }
  }

  # ree counter
  idx.free <- which(free > 0)
  free[idx.free] <- max(PT$free) + 1:length(idx.free)

  LIST <- list(
    id = max(PT$id) + 1:length(lhs),
    lhs = lhs,
    op = op,
    rhs = rhs,
    user = rep(10L, length(lhs)),
    block = block,
    group = group,
    level = rep(1L, length(lhs)),
    free = free,
    ustart = ustart,
    exo = exo,
    start = start,
    est = est
  )

  PT.si <- lav_partable_merge(PT, LIST)

  PT.si
}

# loglikelihood clustered/twolevel data -- conditional.x = TRUE

# YR: first version around Sept 2021

# take model-implied mean+variance matrices, and reorder/augment them
# to facilitate computing of (log)likelihood in the two-level case

# when conditional.x = TRUE:
# - sigma.w and sigma.b: same dimensions, level-1 'Y' variables only
# - sigma.zz: level-2 variables only
# - sigma.yz: cov(level-1, level-2)
# - beta.w: beta y within part
# - beta.b: beta y between part
# - beta.z: beta z (between-only)
lav_mvreg_cluster_implied22l <- function(Lp = NULL,
                                         implied = NULL,
                                         Res.Int.W = NULL,
                                         Res.Int.B = NULL,
                                         Res.Pi.W = NULL,
                                         Res.Pi.B = NULL,
                                         Res.Sigma.W = NULL,
                                         Res.Sigma.B = NULL) {
  if (!is.null(implied)) {
    # FIXME: only for single-group analysis!
    Res.Sigma.W <- implied$res.cov[[1]]
    Res.Int.W <- implied$res.int[[1]]
    Res.Pi.W <- implied$res.slopes[[1]]

    Res.Sigma.B <- implied$res.cov[[2]]
    Res.Int.B <- implied$res.int[[2]]
    Res.Pi.B <- implied$res.slopes[[2]]
  }

  # within/between idx
  within.x.idx <- Lp$within.x.idx[[1]]
  between.y.idx <- Lp$between.y.idx[[2]]
  between.x.idx <- Lp$between.x.idx[[2]]

  # ov.idx per level
  ov.idx <- Lp$ov.idx

  # 'tilde' matrices: ALL variables within and between
  p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]])))

  # only 'y'
  ov.y.idx <- Lp$ov.y.idx

  # two levels only (for now)
  ov.y.idx1 <- ov.y.idx[[1]]
  ov.y.idx2 <- ov.y.idx[[2]]

  # Sigma.W.tilde
  Sigma.W.tilde <- matrix(0, p.tilde, p.tilde)
  Sigma.W.tilde[ov.y.idx1, ov.y.idx1] <- Res.Sigma.W

  # INT.W.tilde
  INT.W.tilde <- matrix(0, p.tilde, 1L)
  INT.W.tilde[ov.y.idx1, 1L] <- Res.Int.W

  # PI.W.tilde
  PI.W.tilde <- matrix(0, p.tilde, ncol(Res.Pi.W))
  PI.W.tilde[ov.y.idx1, ] <- Res.Pi.W

  BETA.W.tilde <- rbind(t(INT.W.tilde), t(PI.W.tilde))



  # Sigma.B.tilde
  Sigma.B.tilde <- matrix(0, p.tilde, p.tilde)
  Sigma.B.tilde[ov.y.idx2, ov.y.idx2] <- Res.Sigma.B

  # INT.B.tilde
  INT.B.tilde <- matrix(0, p.tilde, 1L)
  INT.B.tilde[ov.y.idx2, 1L] <- Res.Int.B

  # PI.B.tilde
  PI.B.tilde <- matrix(0, p.tilde, ncol(Res.Pi.B))
  PI.B.tilde[ov.y.idx2, ] <- Res.Pi.B

  BETA.B.tilde <- rbind(t(INT.B.tilde), t(PI.B.tilde))

  if (length(between.y.idx) > 0L) {
    rm.idx <- c(within.x.idx, between.x.idx, between.y.idx) # between AND x
    beta.z <- BETA.B.tilde[, between.y.idx, drop = FALSE]
    beta.b <- BETA.B.tilde[, -rm.idx, drop = FALSE]
    beta.w <- BETA.W.tilde[, -rm.idx, drop = FALSE]
    sigma.zz <- Sigma.B.tilde[between.y.idx, between.y.idx, drop = FALSE]
    sigma.yz <- Sigma.B.tilde[-rm.idx, between.y.idx, drop = FALSE]
    sigma.b <- Sigma.B.tilde[-rm.idx, -rm.idx, drop = FALSE]
    sigma.w <- Sigma.W.tilde[-rm.idx, -rm.idx, drop = FALSE]
  } else {
    rm.idx <- c(within.x.idx, between.x.idx) # all 'x'
    beta.z <- matrix(0, 0L, 0L)
    sigma.zz <- matrix(0, 0L, 0L)
    beta.b <- BETA.B.tilde[, -rm.idx, drop = FALSE]
    beta.w <- BETA.W.tilde[, -rm.idx, drop = FALSE]
    sigma.b <- Sigma.B.tilde[-rm.idx, -rm.idx, drop = FALSE]
    sigma.w <- Sigma.W.tilde[-rm.idx, -rm.idx, drop = FALSE]
    sigma.yz <- matrix(0, nrow(sigma.w), 0L)
  }


  # beta.wb # FIXme: not correct if some 'x' are splitted (overlap)
  # but because we ALWAYS treat splitted-x as 'y', this is not a problem
  beta.wb <- rbind(beta.w, beta.b[-1, , drop = FALSE])
  beta.wb[1, ] <- beta.wb[1, , drop = FALSE] + beta.b[1, , drop = FALSE]

  list(
    sigma.w = sigma.w, sigma.b = sigma.b, sigma.zz = sigma.zz,
    sigma.yz = sigma.yz, beta.w = beta.w, beta.b = beta.b, beta.z = beta.z,
    beta.wb = beta.wb
  )
}


# recreate implied matrices from 2L matrices
lav_mvreg_cluster_2l2implied <- function(Lp,
                                         sigma.w = NULL,
                                         sigma.b = NULL,
                                         sigma.zz = NULL,
                                         sigma.yz = NULL,
                                         beta.w = NULL,
                                         beta.b = NULL,
                                         beta.z = NULL) {
  # within/between idx
  within.x.idx <- Lp$within.x.idx[[1]]
  between.y.idx <- Lp$between.y.idx[[2]]
  between.x.idx <- Lp$between.x.idx[[2]]

  # ov.idx per level
  ov.idx <- Lp$ov.idx

  # 'tilde' matrices: ALL variables within and between
  p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]])))

  # only 'y'
  ov.y.idx <- Lp$ov.y.idx

  # two levels only (for now)
  ov.y.idx1 <- ov.y.idx[[1]]
  ov.y.idx2 <- ov.y.idx[[2]]

  # Sigma.W.tilde
  Sigma.W.tilde <- matrix(0, p.tilde, p.tilde)
  Sigma.W.tilde[ov.y.idx1, ov.y.idx1] <- sigma.w

  # INT.W.tilde
  INT.W.tilde <- matrix(0, p.tilde, 1L)
  INT.W.tilde[ov.y.idx1, 1L] <- beta.w[1L, ]

  # PI.W.tilde
  PI.W.tilde <- matrix(0, p.tilde, nrow(beta.w) - 1L)
  PI.W.tilde[ov.y.idx1, ] <- t(beta.w[-1L, ])

  # Sigma.B.tilde
  Sigma.B.tilde <- matrix(0, p.tilde, p.tilde)
  Sigma.B.tilde[ov.y.idx1, ov.y.idx1] <- sigma.b

  # INT.B.tilde
  INT.B.tilde <- matrix(0, p.tilde, 1L)
  INT.B.tilde[ov.y.idx1, 1L] <- beta.b[1L, ]

  # PI.B.tilde
  PI.B.tilde <- matrix(0, p.tilde, nrow(beta.b) - 1L)
  PI.B.tilde[ov.y.idx1, ] <- t(beta.b[-1L, ])

  if (length(between.y.idx) > 0L) {
    INT.B.tilde[between.y.idx, 1L] <- beta.z[1L, ]
    PI.B.tilde[between.y.idx, ] <- t(beta.z[-1L, ])
    Sigma.B.tilde[between.y.idx, between.y.idx] <- sigma.zz
    Sigma.B.tilde[ov.y.idx1, between.y.idx] <- sigma.yz
    Sigma.B.tilde[between.y.idx, ov.y.idx1] <- t(sigma.yz)
  }

  Res.Sigma.W <- Sigma.W.tilde[ov.y.idx1, ov.y.idx1, drop = FALSE]
  Res.Int.W <- INT.W.tilde[ov.y.idx1, , drop = FALSE]
  Res.Pi.W <- PI.W.tilde[ov.y.idx1, , drop = FALSE]

  Res.Sigma.B <- Sigma.B.tilde[ov.y.idx2, ov.y.idx2, drop = FALSE]
  Res.Int.B <- INT.B.tilde[ov.y.idx2, , drop = FALSE]
  Res.Pi.B <- PI.B.tilde[ov.y.idx2, , drop = FALSE]

  implied <- list(
    res.cov = list(Res.Sigma.W, Res.Sigma.B),
    res.int = list(Res.Int.W, Res.Int.B),
    res.slopes = list(Res.Pi.W, Res.Pi.B)
  )

  # Note: cov.x and mean.x must be added by the caller
  implied
}

lav_mvreg_cluster_loglik_samplestats_2l <- function(YLp = NULL,
                                                    Lp = NULL,
                                                    Res.Sigma.W = NULL,
                                                    Res.Int.W = NULL,
                                                    Res.Pi.W = NULL,
                                                    Res.Sigma.B = NULL,
                                                    Res.Int.B = NULL,
                                                    Res.Pi.B = NULL,
                                                    out = NULL, # 2l
                                                    Sinv.method = "eigen",
                                                    log2pi = FALSE,
                                                    minus.two = TRUE) {
  # map implied to 2l matrices
  if (is.null(out)) {
    out <- lav_mvreg_cluster_implied22l(
      Lp = Lp, implied = NULL,
      Res.Sigma.W = Res.Sigma.W,
      Res.Int.W = Res.Int.W, Res.Pi.W = Res.Pi.W,
      Res.Sigma.B = Res.Sigma.B,
      Res.Int.B = Res.Int.B, Res.Pi.B = Res.Pi.B
    )
  }
  sigma.w <- out$sigma.w
  sigma.b <- out$sigma.b
  sigma.zz <- out$sigma.zz
  sigma.yz <- out$sigma.yz
  beta.w <- out$beta.w
  beta.b <- out$beta.b
  beta.z <- out$beta.z
  beta.wb <- out$beta.wb

  # check for beta.wb
  if (is.null(out$beta.wb)) {
    beta.wb <- rbind(beta.w, beta.b[-1, , drop = FALSE])
    beta.wb[1, ] <- beta.wb[1, , drop = FALSE] + beta.b[1, , drop = FALSE]
  }

  # log 2*pi
  LOG.2PI <- log(2 * pi)

  # Lp
  nclusters <- Lp$nclusters[[2]]
  cluster.size <- Lp$cluster.size[[2]]
  cluster.sizes <- Lp$cluster.sizes[[2]]
  ncluster.sizes <- Lp$ncluster.sizes[[2]]
  n.s <- Lp$cluster.size.ns[[2]]

  # dependent 'y' level-2 ('Z') only variables?
  between.y.idx <- Lp$between.y.idx[[2]]

  # extract (the many) sample statistics from YLp
  sample.wb <- YLp[[2]]$sample.wb
  sample.YYres.wb1 <- YLp[[2]]$sample.YYres.wb1
  sample.XX.wb1 <- YLp[[2]]$sample.XX.wb1
  sample.wb2 <- YLp[[2]]$sample.wb2
  sample.YYres.wb2 <- YLp[[2]]$sample.YYres.wb2
  sample.YresX.wb2 <- YLp[[2]]$sample.YresX.wb2
  sample.XX.wb2 <- YLp[[2]]$sample.XX.wb2
  sample.clz.Y2.res <- YLp[[2]]$sample.clz.Y2.res
  sample.clz.Y2.XX <- YLp[[2]]$sample.clz.Y2.XX
  sample.clz.Y2.B <- YLp[[2]]$sample.clz.Y2.B
  if (length(between.y.idx) > 0L) {
    sample.clz.ZZ.res <- YLp[[2]]$sample.clz.ZZ.res
    sample.clz.ZZ.XX <- YLp[[2]]$sample.clz.ZZ.XX
    sample.clz.ZZ.B <- YLp[[2]]$sample.clz.ZZ.B
    sample.clz.YZ.res <- YLp[[2]]$sample.clz.YZ.res
    sample.clz.YZ.XX <- YLp[[2]]$sample.clz.YZ.XX
    sample.clz.YresXZ <- YLp[[2]]$sample.clz.YresXZ # zero?
    sample.clz.XWZres <- YLp[[2]]$sample.clz.XWZres
  }

  # reconstruct S.PW
  wb1.diff <- sample.wb - beta.wb
  Y1Y1.wb.res <- (sample.YYres.wb1 +
    t(wb1.diff) %*% sample.XX.wb1 %*% (wb1.diff))

  # this one is weighted -- not the same as crossprod(Y2w.res)
  wb2.diff <- sample.wb2 - beta.wb
  Y2Y2w.res <- (sample.YYres.wb2 +
    sample.YresX.wb2 %*% (wb2.diff) +
    t(wb2.diff) %*% t(sample.YresX.wb2) +
    t(wb2.diff) %*% sample.XX.wb2 %*% (wb2.diff))
  S.PW <- (Y1Y1.wb.res - Y2Y2w.res) / sum(cluster.size - 1)

  # common parts:
  sigma.w.inv <- lav_matrix_symmetric_inverse(
    S = sigma.w,
    logdet = TRUE
  )
  sigma.w.logdet <- attr(sigma.w.inv, "logdet")
  if (length(between.y.idx) > 0L) {
    sigma.zz.inv <- lav_matrix_symmetric_inverse(
      S = sigma.zz,
      logdet = TRUE
    )
    sigma.zz.logdet <- attr(sigma.zz.inv, "logdet")
    sigma.yz.zi <- sigma.yz %*% sigma.zz.inv
    sigma.zi.zy <- t(sigma.yz.zi)
    sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy
  } else {
    sigma.b.z <- sigma.b
  }

  # min 2* logliklihood
  DIST <- numeric(ncluster.sizes)
  LOGDET <- numeric(ncluster.sizes)
  CONST <- numeric(ncluster.sizes)
  for (clz in seq_len(ncluster.sizes)) {
    # cluster size
    nj <- cluster.sizes[clz]

    # data between
    nj.idx <- which(cluster.size == nj)
    y2.diff <- sample.clz.Y2.B[[clz]] - beta.wb
    Y2Yc.yy <- (sample.clz.Y2.res[[clz]] +
      t(y2.diff) %*% sample.clz.Y2.XX[[clz]] %*% (y2.diff))
    if (length(between.y.idx) > 0L) {
      zz.diff <- sample.clz.ZZ.B[[clz]] - beta.z
      Y2Yc.zz <- (sample.clz.ZZ.res[[clz]] +
        t(zz.diff) %*% sample.clz.ZZ.XX[[clz]] %*% (zz.diff))
      Y2Yc.yz <- (sample.clz.YZ.res[[clz]] +
        sample.clz.YresXZ[[clz]] %*% zz.diff + # zero?
        t(y2.diff) %*% sample.clz.XWZres[[clz]] +
        t(y2.diff) %*% sample.clz.YZ.XX[[clz]] %*% zz.diff)
    }

    # construct sigma.j
    sigma.j <- (nj * sigma.b.z) + sigma.w
    sigma.j.inv <- lav_matrix_symmetric_inverse(
      S = sigma.j,
      logdet = TRUE
    )
    sigma.j.logdet <- attr(sigma.j.inv, "logdet")

    if (length(between.y.idx) > 0L) {
      sigma.ji.yz.zi <- sigma.j.inv %*% sigma.yz.zi

      # part 1 -- zz
      Vinv.11 <- sigma.zz.inv + nj * (sigma.zi.zy %*% sigma.ji.yz.zi)
      q.zz <- sum(Vinv.11 * Y2Yc.zz)

      # part 2 -- yz
      q.yz <- -nj * sum(sigma.ji.yz.zi * Y2Yc.yz)
    } else {
      q.zz <- q.yz <- sigma.zz.logdet <- 0
    }

    # part 5 -- yyc
    q.yyc <- -nj * sum(sigma.j.inv * Y2Yc.yy)

    if (log2pi) {
      P <- nj * nrow(sigma.w) + nrow(sigma.zz)
      CONST[clz] <- P * LOG.2PI
    }
    LOGDET[clz] <- sigma.zz.logdet + sigma.j.logdet
    DIST[clz] <- q.zz + 2 * q.yz - q.yyc
  }
  # q.yya + q.yyb
  q.W <- sum(cluster.size - 1) * sum(sigma.w.inv * S.PW)
  # logdet within part
  L.W <- sum(cluster.size - 1) * sigma.w.logdet

  # -2*times logl (without the constant) (for optimization)
  loglik <- sum(LOGDET * n.s) + sum(DIST) + q.W + L.W

  if (log2pi) {
    loglik <- loglik + sum(CONST * n.s)
  }

  # functions below compute -2 * logl
  if (!minus.two) {
    loglik <- loglik / (-2)
  }

  loglik
}

# first derivative -2*logl wrt Beta.W, Beta.B, Sigma.W, Sigma.B
lav_mvreg_cluster_dlogl_2l_samplestats <- function(YLp = NULL,
                                                   Lp = NULL,
                                                   Res.Sigma.W = NULL,
                                                   Res.Int.W = NULL,
                                                   Res.Pi.W = NULL,
                                                   Res.Sigma.B = NULL,
                                                   Res.Int.B = NULL,
                                                   Res.Pi.B = NULL,
                                                   out = NULL, # 2l
                                                   return.list = FALSE,
                                                   Sinv.method = "eigen") {
  # map implied to 2l matrices
  if (is.null(out)) {
    out <- lav_mvreg_cluster_implied22l(
      Lp = Lp, implied = NULL,
      Res.Sigma.W = Res.Sigma.W,
      Res.Int.W = Res.Int.W, Res.Pi.W = Res.Pi.W,
      Res.Sigma.B = Res.Sigma.B,
      Res.Int.B = Res.Int.B, Res.Pi.B = Res.Pi.B
    )
  }
  sigma.w <- out$sigma.w
  sigma.b <- out$sigma.b
  sigma.zz <- out$sigma.zz
  sigma.yz <- out$sigma.yz
  beta.w <- out$beta.w
  beta.b <- out$beta.b
  beta.z <- out$beta.z
  beta.wb <- out$beta.wb

  # check for beta.wb
  if (is.null(out$beta.wb)) {
    beta.wb <- rbind(beta.w, beta.b[-1, , drop = FALSE])
    beta.wb[1, ] <- beta.wb[1, , drop = FALSE] + beta.b[1, , drop = FALSE]
  }

  # Lp
  nclusters <- Lp$nclusters[[2]]
  cluster.size <- Lp$cluster.size[[2]]
  cluster.sizes <- Lp$cluster.sizes[[2]]
  ncluster.sizes <- Lp$ncluster.sizes[[2]]
  n.s <- Lp$cluster.size.ns[[2]]

  within.x.idx <- Lp$within.x.idx[[1]]
  between.y.idx <- Lp$between.y.idx[[2]]

  w1.idx <- seq_len(length(within.x.idx) + 1L)
  b1.idx <- c(1L, seq_len(nrow(beta.wb))[-w1.idx])

  # extract (the many) sample statistics from YLp
  sample.wb <- YLp[[2]]$sample.wb
  sample.YYres.wb1 <- YLp[[2]]$sample.YYres.wb1
  sample.XX.wb1 <- YLp[[2]]$sample.XX.wb1
  sample.wb2 <- YLp[[2]]$sample.wb2
  sample.YYres.wb2 <- YLp[[2]]$sample.YYres.wb2
  sample.YresX.wb2 <- YLp[[2]]$sample.YresX.wb2
  sample.XX.wb2 <- YLp[[2]]$sample.XX.wb2
  sample.clz.Y2.res <- YLp[[2]]$sample.clz.Y2.res
  sample.clz.Y2.XX <- YLp[[2]]$sample.clz.Y2.XX
  sample.clz.Y2.B <- YLp[[2]]$sample.clz.Y2.B
  if (length(between.y.idx) > 0L) {
    sample.clz.ZZ.res <- YLp[[2]]$sample.clz.ZZ.res
    sample.clz.ZZ.XX <- YLp[[2]]$sample.clz.ZZ.XX
    sample.clz.ZZ.B <- YLp[[2]]$sample.clz.ZZ.B
    sample.clz.YZ.res <- YLp[[2]]$sample.clz.YZ.res
    sample.clz.YZ.XX <- YLp[[2]]$sample.clz.YZ.XX
    sample.clz.YresXZ <- YLp[[2]]$sample.clz.YresXZ # zero?
    sample.clz.XWZres <- YLp[[2]]$sample.clz.XWZres
  }

  # reconstruct S.PW
  wb1.diff <- sample.wb - beta.wb
  Y1Y1.wb.res <- (sample.YYres.wb1 +
    t(wb1.diff) %*% sample.XX.wb1 %*% (wb1.diff))

  # this one is weighted -- not the same as crossprod(Y2w.res)
  wb2.diff <- sample.wb2 - beta.wb
  Y2Y2w.res <- (sample.YYres.wb2 +
    sample.YresX.wb2 %*% (wb2.diff) +
    t(wb2.diff) %*% t(sample.YresX.wb2) +
    t(wb2.diff) %*% sample.XX.wb2 %*% (wb2.diff))
  S.PW <- (Y1Y1.wb.res - Y2Y2w.res) / sum(cluster.size - 1)

  # common parts:
  sigma.w.inv <- lav_matrix_symmetric_inverse(S = sigma.w)

  G.beta.w <- matrix(0, ncluster.sizes, length(beta.w))
  G.beta.b <- matrix(0, ncluster.sizes, length(beta.b))
  G.beta.wb <- matrix(0, ncluster.sizes, length(beta.wb))
  G.sigma.w1 <- matrix(0, ncluster.sizes, length(lav_matrix_vech(sigma.w)))
  G.sigma.b <- matrix(0, ncluster.sizes, length(lav_matrix_vech(sigma.b)))

  if (length(between.y.idx) > 0L) {
    G.beta.z <- matrix(0, ncluster.sizes, length(beta.z))
    G.sigma.zz <- matrix(0, ncluster.sizes, length(lav_matrix_vech(sigma.zz)))
    G.sigma.yz <- matrix(0, ncluster.sizes, length(sigma.yz))

    sigma.zz.inv <- lav_matrix_symmetric_inverse(S = sigma.zz)
    sigma.yz.zi <- sigma.yz %*% sigma.zz.inv
    sigma.zi.zy <- t(sigma.yz.zi)
    sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy

    for (clz in seq_len(ncluster.sizes)) {
      # cluster size
      nj <- cluster.sizes[clz]

      y2.diff <- sample.clz.Y2.B[[clz]] - beta.wb
      XX.y2.diff <- sample.clz.Y2.XX[[clz]] %*% y2.diff
      Y2Yc.yy <- sample.clz.Y2.res[[clz]] + crossprod(y2.diff, XX.y2.diff)

      zz.diff <- sample.clz.ZZ.B[[clz]] - beta.z
      Y2Yc.zz <- (sample.clz.ZZ.res[[clz]] +
        t(zz.diff) %*% sample.clz.ZZ.XX[[clz]] %*% (zz.diff))
      Y2Yc.yz <- (sample.clz.YZ.res[[clz]] +
        sample.clz.YresXZ[[clz]] %*% zz.diff + # zero?
        t(y2.diff) %*% sample.clz.XWZres[[clz]] +
        t(y2.diff) %*% sample.clz.YZ.XX[[clz]] %*% zz.diff)

      # construct sigma.j
      sigma.j <- (nj * sigma.b.z) + sigma.w
      sigma.j.inv <- lav_matrix_symmetric_inverse(S = sigma.j)
      sigma.ji.yz.zi <- sigma.j.inv %*% sigma.yz.zi
      sigma.zi.zy.ji <- t(sigma.ji.yz.zi)
      sigma.ji.yz <- sigma.j.inv %*% sigma.yz
      ns.sigma.j.inv <- n.s[clz] * sigma.j.inv
      ns.sigma.zz.inv <- n.s[clz] * sigma.zz.inv
      ns.sigma.yz <- n.s[clz] * sigma.yz
      ns.sigma.ji.yz.zi <- n.s[clz] * sigma.ji.yz.zi

      # common parts
      ZZ.zi.yz.ji <- Y2Yc.zz %*% sigma.zi.zy.ji
      ji.YZ.zi <- sigma.j.inv %*% Y2Yc.yz %*% sigma.zz.inv

      jYZj.yy <- sigma.j.inv %*% Y2Yc.yy %*% sigma.j.inv
      jYZj.yz <- tcrossprod(ji.YZ.zi, sigma.ji.yz)
      jYZj.zz <- sigma.ji.yz.zi %*% ZZ.zi.yz.ji

      jYZj <- nj * (jYZj.yy + jYZj.zz - jYZj.yz - t(jYZj.yz))

      # SIGMA.W (between part)
      g.sigma.w1 <- ns.sigma.j.inv - jYZj
      tmp <- g.sigma.w1 * 2
      diag(tmp) <- diag(g.sigma.w1)
      G.sigma.w1[clz, ] <- lav_matrix_vech(tmp)

      # SIGMA.B
      g.sigma.b <- nj * g.sigma.w1
      tmp <- g.sigma.b * 2
      diag(tmp) <- diag(g.sigma.b)
      G.sigma.b[clz, ] <- lav_matrix_vech(tmp)

      # SIGMA.ZZ
      YZ1 <- ZZ.zi.yz.ji %*% sigma.yz
      YZ2 <- crossprod(Y2Yc.yz, sigma.ji.yz)
      tmp <- (t(sigma.yz) %*% g.sigma.w1 %*% sigma.yz
        - 1 / nj * Y2Yc.zz - t(YZ1) - YZ1 + t(YZ2) + YZ2)
      g.sigma.zz <- (ns.sigma.zz.inv +
        nj * sigma.zz.inv %*% tmp %*% sigma.zz.inv)
      tmp <- g.sigma.zz * 2
      diag(tmp) <- diag(g.sigma.zz)
      G.sigma.zz[clz, ] <- lav_matrix_vech(tmp)

      # SIGMA.ZY
      tmp1 <- crossprod(ZZ.zi.yz.ji, sigma.zz.inv)
      tmp2 <- ns.sigma.ji.yz.zi
      tmp3 <- ji.YZ.zi
      tmp4 <- jYZj %*% sigma.yz.zi
      g.sigma.yz <- 2 * nj * (tmp1 - tmp2 - tmp3 + tmp4)
      G.sigma.yz[clz, ] <- lav_matrix_vec(g.sigma.yz)

      # BETA.Z
      A <- (sigma.zz.inv + nj * (sigma.zi.zy.ji %*% sigma.yz.zi)) # symm!
      B <- nj * (sigma.zi.zy.ji)
      tmp.z <- (sample.clz.ZZ.XX[[clz]] %*% zz.diff %*% A -
        (t(sample.clz.YresXZ[[clz]]) +
          t(sample.clz.YZ.XX[[clz]]) %*% y2.diff) %*% t(B))
      G.beta.z[clz, ] <- as.vector(-2 * tmp.z)

      # BETA.W (between part only) + BETA.B
      tmp <- (sample.clz.XWZres[[clz]] +
        sample.clz.YZ.XX[[clz]] %*% zz.diff)
      out.b <- tmp %*% sigma.zi.zy.ji - XX.y2.diff %*% sigma.j.inv
      out.w <- out.b + XX.y2.diff %*% sigma.w.inv
      tmp.b <- out.b[b1.idx, , drop = FALSE]
      tmp.w <- out.w[w1.idx, , drop = FALSE]
      G.beta.b[clz, ] <- as.vector(2 * nj * tmp.b)
      G.beta.w[clz, ] <- as.vector(2 * nj * tmp.w)
    } # clz

    d.beta.w1 <- matrix(colSums(G.beta.w), nrow(beta.w), ncol(beta.w))
    d.beta.b <- matrix(colSums(G.beta.b), nrow(beta.b), ncol(beta.b))
    d.sigma.w1 <- lav_matrix_vech_reverse(colSums(G.sigma.w1))
    d.sigma.b <- lav_matrix_vech_reverse(colSums(G.sigma.b))

    # z
    d.beta.z <- matrix(colSums(G.beta.z), nrow(beta.z), ncol(beta.z))
    d.sigma.zz <- lav_matrix_vech_reverse(colSums(G.sigma.zz))
    d.sigma.yz <- matrix(colSums(G.sigma.yz), nrow(sigma.yz), ncol(sigma.yz))
  } # between.y.idx

  else { # no beween.y.idx

    for (clz in seq_len(ncluster.sizes)) {
      # cluster size
      nj <- cluster.sizes[clz]

      y2.diff <- sample.clz.Y2.B[[clz]] - beta.wb
      XX.y2.diff <- sample.clz.Y2.XX[[clz]] %*% y2.diff
      Y2Yc.yy <- sample.clz.Y2.res[[clz]] + crossprod(y2.diff, XX.y2.diff)

      # construct sigma.j
      sigma.j <- (nj * sigma.b) + sigma.w
      sigma.j.inv <- lav_matrix_symmetric_inverse(S = sigma.j)

      # common part
      jYYj <- nj * sigma.j.inv %*% Y2Yc.yy %*% sigma.j.inv

      # SIGMA.W (between part)
      g.sigma.w1 <- (n.s[clz] * sigma.j.inv) - jYYj
      tmp <- g.sigma.w1 * 2
      diag(tmp) <- diag(g.sigma.w1)
      G.sigma.w1[clz, ] <- lav_matrix_vech(tmp)

      # SIGMA.B
      g.sigma.b <- nj * g.sigma.w1
      tmp <- g.sigma.b * 2
      diag(tmp) <- diag(g.sigma.b)
      G.sigma.b[clz, ] <- lav_matrix_vech(tmp)

      # BETA.W (between part only) + BETA.B
      out.b <- -1 * XX.y2.diff %*% sigma.j.inv
      out.w <- out.b + XX.y2.diff %*% sigma.w.inv
      tmp.b <- out.b[b1.idx, , drop = FALSE]
      tmp.w <- out.w[w1.idx, , drop = FALSE]
      G.beta.b[clz, ] <- as.vector(2 * nj * tmp.b)
      G.beta.w[clz, ] <- as.vector(2 * nj * tmp.w)
    } # cl

    d.beta.w1 <- matrix(colSums(G.beta.w), nrow(beta.w), ncol(beta.w))
    d.beta.b <- matrix(colSums(G.beta.b), nrow(beta.b), ncol(beta.b))
    d.sigma.w1 <- lav_matrix_vech_reverse(colSums(G.sigma.w1))
    d.sigma.b <- lav_matrix_vech_reverse(colSums(G.sigma.b))

    # z
    d.beta.z <- matrix(0, 0L, 0L)
    d.sigma.zz <- matrix(0, 0L, 0L)
    d.sigma.yz <- matrix(0, 0L, 0L)
  } # no-between-y

  # Sigma.W (bis)
  d.sigma.w2 <- sum(cluster.size - 1) * (sigma.w.inv
  - sigma.w.inv %*% S.PW %*% sigma.w.inv)
  tmp <- d.sigma.w2 * 2
  diag(tmp) <- diag(d.sigma.w2)
  d.sigma.w2 <- tmp

  d.sigma.w <- d.sigma.w1 + d.sigma.w2

  # beta.w (bis)
  d.beta.w2 <- -2 * (sample.XX.wb1 %*% (sample.wb - beta.wb))[w1.idx, , drop = FALSE] %*% sigma.w.inv

  d.beta.w <- d.beta.w1 + d.beta.w2

  # rearrange
  dimplied <- lav_mvreg_cluster_2l2implied(Lp,
    sigma.w = d.sigma.w, sigma.b = d.sigma.b,
    sigma.zz = d.sigma.zz, sigma.yz = d.sigma.yz,
    beta.w = d.beta.w, beta.b = d.beta.b, beta.z = d.beta.z
  )

  if (return.list) {
    return(dimplied)
  }

  # as a single vector
  out <- c(
    drop(dimplied$res.int[[1]]),
    lav_matrix_vec(dimplied$res.slopes[[1]]),
    lav_matrix_vech(dimplied$res.cov[[1]]),
    drop(dimplied$res.int[[2]]),
    lav_matrix_vec(dimplied$res.slopes[[2]]),
    lav_matrix_vech(dimplied$res.cov[[2]])
  )
  out
}

# cluster-wise scores -2*logl wrt Beta.W, Beta.B, Sigma.W, Sigma.B
lav_mvreg_cluster_scores_2l <- function(Y1 = NULL,
                                        YLp = NULL,
                                        Lp = NULL,
                                        Res.Sigma.W = NULL,
                                        Res.Int.W = NULL,
                                        Res.Pi.W = NULL,
                                        Res.Sigma.B = NULL,
                                        Res.Int.B = NULL,
                                        Res.Pi.B = NULL,
                                        out = NULL, # 2l
                                        Sinv.method = "eigen") {
  # map implied to 2l matrices
  if (is.null(out)) {
    out <- lav_mvreg_cluster_implied22l(
      Lp = Lp, implied = NULL,
      Res.Sigma.W = Res.Sigma.W,
      Res.Int.W = Res.Int.W, Res.Pi.W = Res.Pi.W,
      Res.Sigma.B = Res.Sigma.B,
      Res.Int.B = Res.Int.B, Res.Pi.B = Res.Pi.B
    )
  }
  sigma.w <- out$sigma.w
  sigma.b <- out$sigma.b
  sigma.zz <- out$sigma.zz
  sigma.yz <- out$sigma.yz
  beta.w <- out$beta.w
  beta.b <- out$beta.b
  beta.z <- out$beta.z
  beta.wb <- out$beta.wb

  # check for beta.wb
  if (is.null(out$beta.wb)) {
    beta.wb <- rbind(beta.w, beta.b[-1, , drop = FALSE])
    beta.wb[1, ] <- beta.wb[1, , drop = FALSE] + beta.b[1, , drop = FALSE]
  }

  # Lp
  nclusters <- Lp$nclusters[[2]]
  cluster.size <- Lp$cluster.size[[2]]
  cluster.idx <- Lp$cluster.idx[[2]]

  within.x.idx <- Lp$within.x.idx[[1]]
  between.idx <- Lp$between.idx[[2]]
  between.y.idx <- Lp$between.y.idx[[2]]
  between.x.idx <- Lp$between.x.idx[[2]]

  y1.idx <- Lp$ov.y.idx[[1]]
  x1.idx <- c(within.x.idx, between.x.idx) # in that order

  # residuals for 'Y'
  Y1.wb <- Y1[, y1.idx, drop = FALSE]

  if (length(x1.idx) > 0L) {
    EXO.wb <- cbind(1, Y1[, x1.idx, drop = FALSE])
    Y1.wb.hat <- EXO.wb %*% beta.wb
    Y1.wb.res <- Y1.wb - Y1.wb.hat
  } else {
    Y1.wb.res <- Y1.wb
  }

  # residuals 'Y' (level 2)
  Y2 <- YLp[[2]]$Y2
  if (length(x1.idx) > 0L) {
    EXO.wb2 <- cbind(1, Y2[, x1.idx, drop = FALSE])
    Y2w.res <- Y2[, y1.idx, drop = FALSE] - EXO.wb2 %*% beta.wb
  } else {
    EXO.wb2 <- matrix(1, nrow(Y2), 1L)
    Y2w.res <- Y2[, y1.idx, drop = FALSE]
  }

  # residual 'Z' (level 2)
  if (length(between.y.idx) > 0L) {
    if (length(between.x.idx) > 0L) {
      EXO.z <- cbind(1, Y2[, between.x.idx, drop = FALSE])
      Y2.z <- Y2[, between.y.idx, drop = FALSE]
      Y2z.res <- Y2.z - EXO.z %*% beta.z
      # sample.z
      # XX.z <- crossprod(EXO.z)
      # sample.z <- try(solve(XX.z, crossprod(EXO.z, Y2.z)))
      # if(inherits(sample.z, "try-error")) {
      #    sample.z <- MASS::ginv(XX.z) %*% crossprod(EXO.z, Y2.z)
      # }

      # sample.wb2
      # sample.wb2 <- YLp[[2]]$sample.wb2
    } else {
      Y2z.res <- Y2[, between.y.idx, drop = FALSE]
    }
  }

  # common parts:
  sigma.w.inv <- lav_matrix_symmetric_inverse(S = sigma.w)

  G.beta.w1 <- matrix(0, nclusters, length(beta.w))
  G.beta.b <- matrix(0, nclusters, length(beta.b))
  G.beta.wb <- matrix(0, nclusters, length(beta.wb))
  G.sigma.w1 <- matrix(0, nclusters, length(lav_matrix_vech(sigma.w)))
  G.sigma.b <- matrix(0, nclusters, length(lav_matrix_vech(sigma.b)))


  if (length(between.y.idx) > 0L) {
    G.beta.z <- matrix(0, nclusters, length(beta.z))
    G.sigma.zz <- matrix(0, nclusters, length(lav_matrix_vech(sigma.zz)))
    G.sigma.yz <- matrix(0, nclusters, length(sigma.yz))

    sigma.zz.inv <- lav_matrix_symmetric_inverse(S = sigma.zz)
    sigma.yz.zi <- sigma.yz %*% sigma.zz.inv
    sigma.zi.zy <- t(sigma.yz.zi)
    sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy

    for (cl in seq_len(nclusters)) {
      # cluster size
      nj <- cluster.size[cl]

      # data within for the cluster (centered)
      Y1m <- Y1.wb.res[cluster.idx == cl, , drop = FALSE]
      yc <- Y2w.res[cl, ]

      # data between
      zc <- Y2z.res[cl, ]
      Y2Yc.yy <- tcrossprod(Y2w.res[cl, ])
      Y2Yc.zz <- tcrossprod(Y2z.res[cl, ])
      Y2Yc.yz <- tcrossprod(Y2w.res[cl, ], Y2z.res[cl, ])

      # construct sigma.j
      sigma.j <- (nj * sigma.b.z) + sigma.w
      sigma.j.inv <- lav_matrix_symmetric_inverse(S = sigma.j)
      sigma.ji.yz.zi <- sigma.j.inv %*% sigma.yz.zi
      sigma.zi.zy.ji <- t(sigma.ji.yz.zi)
      sigma.ji.yz <- sigma.j.inv %*% sigma.yz

      # common parts
      ZZ.zi.yz.ji <- Y2Yc.zz %*% sigma.zi.zy.ji
      ji.YZ.zi <- sigma.j.inv %*% Y2Yc.yz %*% sigma.zz.inv

      jYZj.yy <- sigma.j.inv %*% Y2Yc.yy %*% sigma.j.inv
      jYZj.yz <- tcrossprod(ji.YZ.zi, sigma.ji.yz)
      jYZj.zz <- sigma.ji.yz.zi %*% ZZ.zi.yz.ji

      jYZj <- nj * (jYZj.yy + jYZj.zz - jYZj.yz - t(jYZj.yz))

      # SIGMA.W (between part)
      g.sigma.w1 <- sigma.j.inv - jYZj
      tmp <- g.sigma.w1 * 2
      diag(tmp) <- diag(g.sigma.w1)
      G.sigma.w1[cl, ] <- lav_matrix_vech(tmp)

      # SIGMA.W (within part)
      # g.sigma.w2 <- ( (nj-1) * sigma.w.inv
      #    - sigma.w.inv %*% (crossprod(Y1m) - nj*Y2Yc.yy) %*% sigma.w.inv )
      # tmp <- g.sigma.w2*2; diag(tmp) <- diag(g.sigma.w2)
      # G.sigma.w2[cl,] <- lav_matrix_vech(tmp)
      # G.sigma.w[cl,] <- G.sigma.w1[cl,] + G.sigma.w2[cl,]

      # SIGMA.B
      g.sigma.b <- nj * g.sigma.w1
      tmp <- g.sigma.b * 2
      diag(tmp) <- diag(g.sigma.b)
      G.sigma.b[cl, ] <- lav_matrix_vech(tmp)

      # SIGMA.ZZ
      YZ1 <- ZZ.zi.yz.ji %*% sigma.yz
      YZ2 <- crossprod(Y2Yc.yz, sigma.ji.yz)
      tmp <- (t(sigma.yz) %*% g.sigma.w1 %*% sigma.yz
        - (1 / nj * Y2Yc.zz + t(YZ1) + YZ1 - t(YZ2) - YZ2))
      g.sigma.zz <- (sigma.zz.inv +
        nj * sigma.zz.inv %*% tmp %*% sigma.zz.inv)
      tmp <- g.sigma.zz * 2
      diag(tmp) <- diag(g.sigma.zz)
      G.sigma.zz[cl, ] <- lav_matrix_vech(tmp)

      # SIGMA.ZY
      # g.sigma.yz <- 2 * nj * (
      #              (sigma.j.inv %*%
      #                  (sigma.yz.zi %*% Y2Yc.zz - sigma.yz - Y2Yc.yz)
      #                   + jYZj %*% sigma.yz) %*% sigma.zz.inv )
      tmp1 <- crossprod(ZZ.zi.yz.ji, sigma.zz.inv)
      tmp2 <- sigma.ji.yz.zi
      tmp3 <- ji.YZ.zi
      tmp4 <- jYZj %*% sigma.yz.zi
      g.sigma.yz <- 2 * nj * (tmp1 - tmp2 - tmp3 + tmp4)
      G.sigma.yz[cl, ] <- lav_matrix_vec(g.sigma.yz)

      # BETA.Z
      # here, we avoid the (sample.z - beta.z) approach
      exo.z <- cbind(1, Y2[cl, between.x.idx, drop = FALSE])
      tmp1 <- (sigma.zz.inv + nj * (sigma.zi.zy.ji %*% sigma.yz.zi)) %*% zc
      tmp2 <- nj * (sigma.zi.zy.ji) %*% yc
      tmp.z <- crossprod(exo.z, drop(tmp1 - tmp2))
      G.beta.z[cl, ] <- as.vector(-2 * tmp.z)

      # BETA.W
      #            exo.w <- cbind(1,
      #                           Y1[cluster.idx == cl, within.x.idx, drop = FALSE])
      #            G.beta.w[cl,] <- as.vector( 2 * t(exo.w) %*% (
      #                                 matrix(1, nj, 1) %x% (zc %*% sigma.zi.zy.ji -
      #                                                       yc %*% sigma.j.inv +
      #                                                       yc %*% sigma.w.inv) -
      #                                 Y1m %*% sigma.w.inv) )

      # BETA.W (between part only)
      exo2.w <- cbind(1, Y2[cl, within.x.idx, drop = FALSE])
      tmp2 <- (zc %*% sigma.zi.zy.ji -
        yc %*% sigma.j.inv +
        yc %*% sigma.w.inv)
      G.beta.w1[cl, ] <- as.vector(2 * nj * crossprod(exo2.w, tmp2))

      # BETA.W (within part only)
      # exo.w <- cbind(1,
      #               Y1[cluster.idx == cl, within.x.idx, drop = FALSE])
      # tmp1 <- - Y1m %*% sigma.w.inv
      # G.beta.ww <- as.vector( 2 * crossprod(exo.w, tmp1) )
      # G.beta.w[cl,] <- G.beta.w1 + G.beta.ww
      # G.beta.w2[cl,] <- G.beta.ww

      # BETA.B
      exo2.b <- cbind(1, Y2[cl, between.x.idx, drop = FALSE])
      tmp <- (zc %*% sigma.zi.zy.ji - yc %*% sigma.j.inv)
      G.beta.b[cl, ] <- as.vector(2 * nj * crossprod(exo2.b, tmp))
    } # cl
  } # between.y.idx

  else { # no beween.y.idx

    for (cl in seq_len(nclusters)) {
      # cluster size
      nj <- cluster.size[cl]

      # data within for the cluster (centered)
      Y1m <- Y1.wb.res[cluster.idx == cl, , drop = FALSE]
      yc <- Y2w.res[cl, ]

      # data between
      Y2Yc.yy <- tcrossprod(Y2w.res[cl, ])

      # construct sigma.j
      sigma.j <- (nj * sigma.b) + sigma.w
      sigma.j.inv <- lav_matrix_symmetric_inverse(S = sigma.j)

      # common part
      jYYj <- nj * sigma.j.inv %*% Y2Yc.yy %*% sigma.j.inv

      # SIGMA.W
      # g.sigma.w <- ( (nj-1) * sigma.w.inv
      #    - sigma.w.inv %*% (crossprod(Y1m) - nj*Y2Yc.yy) %*% sigma.w.inv
      #    + sigma.j.inv - jYYj )
      # tmp <- g.sigma.w*2; diag(tmp) <- diag(g.sigma.w)
      # G.sigma.w[cl,] <- lav_matrix_vech(tmp)

      # SIGMA.W (between part)
      g.sigma.w1 <- sigma.j.inv - jYYj
      tmp <- g.sigma.w1 * 2
      diag(tmp) <- diag(g.sigma.w1)
      G.sigma.w1[cl, ] <- lav_matrix_vech(tmp)

      # SIGMA.B
      g.sigma.b <- nj * (sigma.j.inv - jYYj)
      tmp <- g.sigma.b * 2
      diag(tmp) <- diag(g.sigma.b)
      G.sigma.b[cl, ] <- lav_matrix_vech(tmp)

      # BETA.W (between part only)
      exo2.w <- cbind(1, Y2[cl, within.x.idx, drop = FALSE])
      tmp2 <- (-yc %*% sigma.j.inv + yc %*% sigma.w.inv)
      G.beta.w1[cl, ] <- as.vector(2 * nj * crossprod(exo2.w, tmp2))

      # BETA.B
      exo2.b <- cbind(1, Y2[cl, between.x.idx, drop = FALSE])
      tmp <- -yc %*% sigma.j.inv
      G.beta.b[cl, ] <- as.vector(2 * nj * crossprod(exo2.b, tmp))
    } # cl
  } # no-between-y

  # beta.w (bis)

  #    d.beta.w2 <- -2 * t(EXO.wb[,1:(length(within.x.idx) + 1L), drop = FALSE]) %*% Y1.wb.res %*% sigma.w.inv

  Y1.wb.res.i <- Y1.wb.res %*% sigma.w.inv
  w1.idx <- seq_len(length(within.x.idx) + 1L)
  a1.idx <- rep(w1.idx, times = ncol(Y1.wb.res.i))
  b1.idx <- rep(seq_len(ncol(Y1.wb.res.i)), each = length(w1.idx))
  TMP <- EXO.wb[, a1.idx, drop = FALSE] * Y1.wb.res.i[, b1.idx, drop = FALSE]
  G.beta.w2 <- -2 * rowsum.default(TMP, cluster.idx,
    reorder = FALSE,
    na.rm = TRUE
  )
  G.beta.w <- G.beta.w1 + G.beta.w2

  # Sigma.W (bis)
  # d.sigma.w2 <- sum(cluster.size - 1) * ( sigma.w.inv
  #               - sigma.w.inv %*% S.PW %*% sigma.w.inv )
  # tmp <- d.sigma.w2*2; diag(tmp) <- diag(d.sigma.w2)
  # d.sigma.w2 <- tmp

  # g.sigma.w2 <- ( (nj-1) * sigma.w.inv
  #        - sigma.w.inv %*% (crossprod(Y1m) - nj*Y2Yc.yy) %*% sigma.w.inv )

  Y1a.res <- Y1.wb.res - Y2w.res[cluster.idx, , drop = FALSE]
  Y1a.res.i <- Y1a.res %*% sigma.w.inv
  idx1 <- lav_matrix_vech_col_idx(nrow(sigma.w))
  idx2 <- lav_matrix_vech_row_idx(nrow(sigma.w))
  SW2 <- matrix(lav_matrix_vech(sigma.w.inv),
    nrow = nclusters,
    length(lav_matrix_vech(sigma.w.inv)), byrow = TRUE
  )
  SW2 <- SW2 * (cluster.size - 1)
  TMP <- Y1a.res.i[, idx1, drop = FALSE] * Y1a.res.i[, idx2, drop = FALSE]
  TMP2 <- rowsum.default(TMP, cluster.idx, reorder = FALSE, na.rm = TRUE)
  G.sigma.w2 <- 2 * (SW2 - TMP2)
  diagh.idx <- lav_matrix_diagh_idx(nrow(sigma.w))
  G.sigma.w2[, diagh.idx] <- G.sigma.w2[, diagh.idx, drop = FALSE] / 2
  G.sigma.w <- G.sigma.w1 + G.sigma.w2



  # rearrange columns to Res.Int.W, Res.Pi.W, Res.Sigma.W,
  #                      Res.Int.B, Res.Pi.B, Res.Sigma.B

  # ov.idx per level
  ov.idx <- Lp$ov.idx

  # 'tilde' matrices: ALL variables within and between
  p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]])))
  p.tilde.star <- p.tilde * (p.tilde + 1) / 2
  B.tilde <- lav_matrix_vech_reverse(seq_len(p.tilde.star))

  # only 'y'
  ov.y.idx <- Lp$ov.y.idx

  # two levels only (for now)
  ov.y.idx1 <- ov.y.idx[[1]]
  ov.y.idx2 <- ov.y.idx[[2]]

  # WITHIN (is easy)
  BETA.W.idx <- matrix(seq_len(length(beta.w)), nrow(beta.w), ncol(beta.w))
  BETA.B.idx <- matrix(seq_len(length(beta.b)), nrow(beta.b), ncol(beta.b))

  Res.Int.W <- G.beta.w[, BETA.W.idx[1L, ], drop = FALSE]
  Res.Pi.W <- G.beta.w[, lav_matrix_vecr(BETA.W.idx[-1L, ]), drop = FALSE]
  Res.Sigma.W <- G.sigma.w

  # Sigma.B
  Sigma.B.tilde <- matrix(0, nclusters, p.tilde.star)
  col.idx <- lav_matrix_vech(B.tilde[ov.y.idx1, ov.y.idx1, drop = FALSE])
  Sigma.B.tilde[, col.idx] <- G.sigma.b

  # Int.B
  BETA.B.tilde <- matrix(seq_len(nrow(beta.b) * p.tilde), nrow(beta.b), p.tilde)
  Int.B <- matrix(0, nclusters, p.tilde)
  Int.B[, ov.y.idx1] <- G.beta.b[, BETA.B.idx[1L, ]]

  # Pi.B
  Pi.B <- matrix(0, nclusters, p.tilde * (nrow(beta.b) - 1L))
  col.idx <- lav_matrix_vecr(BETA.B.tilde[-1L, ov.y.idx1, drop = FALSE])
  Pi.B[, col.idx] <- G.beta.b[, lav_matrix_vecr(BETA.B.idx[-1L, ]), drop = FALSE]

  if (length(between.y.idx) > 0L) {
    # Sigma.B: add yz/zz parts
    col.idx <- lav_matrix_vec(B.tilde[ov.y.idx1, between.y.idx, drop = FALSE])
    Sigma.B.tilde[, col.idx] <- G.sigma.yz
    col.idx <- lav_matrix_vech(B.tilde[between.y.idx, between.y.idx,
      drop = FALSE
    ])
    Sigma.B.tilde[, col.idx] <- G.sigma.zz

    # Int.B: add z-part
    BETA.Z.idx <- matrix(seq_len(length(beta.z)), nrow(beta.z), ncol(beta.z))
    Int.B[, between.y.idx] <- G.beta.z[, BETA.Z.idx[1L, ], drop = FALSE]

    # Pi.B: add beta.z
    col.idx <- lav_matrix_vecr(BETA.B.tilde[-1L, between.y.idx, drop = FALSE])
    Pi.B[, col.idx] <-
      G.beta.z[, lav_matrix_vecr(BETA.Z.idx[-1L, ]), drop = FALSE]
  }

  # only extract ov.y.idx2 for BETWEEN
  col.idx <- lav_matrix_vech(B.tilde[ov.y.idx2, ov.y.idx2, drop = FALSE])
  Res.Sigma.B <- Sigma.B.tilde[, col.idx, drop = FALSE]

  Res.Int.B <- Int.B[, ov.y.idx2, drop = FALSE]

  col.idx <- lav_matrix_vecr(BETA.B.tilde[-1, ov.y.idx2])
  Res.Pi.B <- Pi.B[, col.idx, drop = FALSE]

  SCORES <- cbind(
    Res.Int.W, Res.Pi.W, Res.Sigma.W,
    Res.Int.B, Res.Pi.B, Res.Sigma.B
  )

  SCORES
}

# first-order information: outer crossprod of scores per cluster
lav_mvreg_cluster_information_firstorder <- function(Y1 = NULL,
                                                     YLp = NULL,
                                                     Lp = NULL,
                                                     Res.Sigma.W = NULL,
                                                     Res.Int.W = NULL,
                                                     Res.Pi.W = NULL,
                                                     Res.Sigma.B = NULL,
                                                     Res.Int.B = NULL,
                                                     Res.Pi.B = NULL,
                                                     divide.by.two = FALSE,
                                                     Sinv.method = "eigen") {
  N <- NROW(Y1)

  SCORES <- lav_mvreg_cluster_scores_2l(
    Y1 = Y1,
    YLp = YLp,
    Lp = Lp,
    Res.Sigma.W = Res.Sigma.W,
    Res.Int.W = Res.Int.W,
    Res.Pi.W = Res.Pi.W,
    Res.Sigma.B = Res.Sigma.B,
    Res.Int.B = Res.Int.B,
    Res.Pi.B = Res.Pi.B,
    Sinv.method = Sinv.method
  )

  # divide by 2 (if we want scores wrt objective function)
  if (divide.by.two) {
    SCORES <- SCORES / 2
  }

  # unit information
  information <- crossprod(SCORES) / Lp$nclusters[[2]]

  information
}

# here, we generate new models based on the original model in lavobject
# 1. the independence model
# 2. the unrestricted model
# 3. model + extra parameters (for modindices/lavTestScore)
# 4. catML fit based on DWLS fit (for robust RMSEA/CFI)


# 1. fit an 'independence/baseline' model
#    note that for ML (and ULS and DWLS), the 'estimates' of the
#    independence model are simply the observed variances
#    but for GLS and WLS, this is not the case!!
#
#  - YR 01 Feb 2026: allow for baseline.type = "nested"
lav_object_independence <- lav_object_baseline <- function(object = NULL,
                                                           # or
                                                           lavsamplestats = NULL,
                                                           lavdata = NULL,
                                                           lavcache = NULL,
                                                           lavoptions = NULL,
                                                           lavpartable = NULL,
                                                           lavh1 = NULL,
                                                           # local options
                                                           se = FALSE) {
  # object or slots?
  if (!is.null(object)) {
    stopifnot(inherits(object, "lavaan"))
    object <- lav_object_check_version(object)

    # extract needed slots
    lavsamplestats <- object@SampleStats
    lavdata <- object@Data
    lavcache <- object@Cache
    lavoptions <- object@Options
    lavpartable <- object@ParTable
    lavpta <- object@pta
    lavh1 <- object@h1
    if (is.null(lavoptions$estimator.args)) {
      lavoptions$estimator.args <- list()
    }
  } else {
    lavpta <- lav_partable_attributes(lavpartable)
    lavpartable <- lav_partable_set_cache(lavpartable, lavpta)
  }

  # if two-level, force conditional.x = FALSE (for now)
  if (lavdata@nlevels > 1L && lavoptions$conditional.x) {
    lavoptions$conditional.x <- FALSE
  }

  # construct parameter table for independence model
  if (!is.null(lavoptions$baseline.type) &&
    lavoptions$baseline.type == "nested") {
    lavpartable <- lav_partable_baseline(
      lavobject = NULL,
      lavpartable = lavpartable, lavh1 = lavh1
    )
  } else {
    lavpartable <- lav_partable_indep_or_unrestricted(
      lavobject = NULL,
      lavdata = lavdata, lavpta = lavpta, lavoptions = lavoptions,
      lavsamplestats = lavsamplestats, lavh1 = lavh1, independent = TRUE
    )
  }

  # new in 0.6-6: add lower bounds for ov.var
  if (!is.null(lavoptions$optim.bounds)) {
    lavoptions$bounds <- "doe.maar"
    lavoptions$effect.coding <- "" # to avoid warning
    lavoptions$optim.bounds <- list(lower = "ov.var")
    lavpartable <- lav_partable_add_bounds(
      partable = lavpartable,
      lavh1 = lavh1, lavdata = lavdata,
      lavsamplestats = lavsamplestats, lavoptions = lavoptions
    )
  }

  # new in 0.6-8: if DLS, change to sample-based
  if (lavoptions$estimator == "DLS") {
    if (lavoptions$estimator.args$dls.GammaNT == "sample") {
      # nothing to do
    } else {
      lavoptions$estimator.args$dls.GammaNT <- "sample"
      dls.a <- lavoptions$estimator.args$dls.a
      for (g in 1:lavsamplestats@ngroups) {
        GammaNT <- lav_samplestats_Gamma_NT(
          COV            = lavsamplestats@cov[[g]],
          MEAN           = lavsamplestats@mean[[g]],
          rescale        = FALSE,
          x.idx          = lavsamplestats@x.idx[[g]],
          fixed.x        = lavoptions$fixed.x,
          conditional.x  = lavoptions$conditional.x,
          meanstructure  = lavoptions$meanstructure,
          slopestructure = lavoptions$conditional.x
        )
        W.DLS <- (1 - dls.a) * lavsamplestats@NACOV[[g]] + dls.a * GammaNT
        # overwrite
        lavsamplestats@WLS.V[[g]] <- lav_matrix_symmetric_inverse(W.DLS)
      }
    }
  }

  # se
  if (se) {
    if (lavoptions$se == "none") {
      lavoptions$se <- "standard"
    }
  } else {
    # 0.6-18: slower, but safer to just keep it

    # 0.6-20 -- except if se = "bootstrap" -> "none"
    if (lavoptions$se == "bootstrap") {
      lavoptions$se <- "none"
    }

    ## FIXME: if test = scaled, we need it anyway?
    # if(lavoptions$missing %in% c("two.stage", "two.stage.robust")) {
    # don't touch it
    # } else {
    #    lavoptions$se <- "none"
    # }
  }

  # change options
  lavoptions$h1 <- FALSE # already provided by lavh1
  lavoptions$baseline <- FALSE # of course
  lavoptions$loglik <- TRUE # eg for multilevel
  lavoptions$implied <- TRUE # needed for loglik (multilevel)
  lavoptions$check.start <- FALSE
  lavoptions$check.gradient <- FALSE
  lavoptions$check.post <- FALSE
  lavoptions$check.vcov <- FALSE
  lavoptions$optim.bounds <- list() # we already have the bounds
  lavoptions$start <- "default" # don't re-use user-specified starting values
  lavoptions$rstarts <- 0L # no random starts

  # ALWAYS do.fit and set optim.method = "nlminb" (if npar > 0)
  npar <- lav_partable_npar(lavpartable)
  if (npar > 0L) {
    lavoptions$do.fit <- TRUE
    if(lavoptions$optim.method != "noniter") {
      lavoptions$optim.method <- "nlminb"
    }
  } else {
    # perhaps a correlation structure?
    lavoptions$optim.method <- "none"
    lavoptions$optim.force.converged <- TRUE
  }

  # needed?
  if (any(lavpartable$op == "~1")) lavoptions$meanstructure <- TRUE

  # FIXME: it is crucial that the order of the ov's, as returned by
  # lav_object_vnames() remains the same
  # so lav_object_vnames(object) should equal lav_object_vnames(lavpartable)
  # otherwise, we will use the wrong sample statistics!!!
  #
  # this seems ok now, because we first generate the covariances in
  # lavpartable, and they should be in the right order (unlike the
  # intercepts)

  FIT <- lavaan(lavpartable,
    slotOptions     = lavoptions,
    slotSampleStats = lavsamplestats,
    slotData        = lavdata,
    slotCache       = lavcache,
    sloth1          = lavh1
  )

  FIT
}


# 2. unrestricted model
lav_object_unrestricted <- function(object, se = FALSE) {
  object <- lav_object_check_version(object)
  # construct parameter table for unrestricted model
  lavpartable <- lav_partable_unrestricted(object)

  # adapt options
  lavoptions <- object@Options

  # se
  if (se) {
    if (lavoptions$se == "none") {
      lavoptions$se <- "standard"
    }
  } else {
    ## FIXME: if test = scaled, we need it anyway?
    lavoptions$se <- "none"
  }

  # ALWAYS do.fit
  lavoptions$do.fit <- TRUE

  # needed?
  if (any(lavpartable$op == "~1")) lavoptions$meanstructure <- TRUE

  lavh1 <- object@h1

  FIT <- lavaan(lavpartable,
    slotOptions     = lavoptions,
    slotSampleStats = object@SampleStats,
    slotData        = object@Data,
    slotCache       = object@Cache,
    sloth1          = lavh1
  )

  FIT
}


# 3. extended model (used for modification indices)
lav_object_extended <- function(object, add = NULL,
                                remove.duplicated = TRUE,
                                all.free = FALSE,
                                do.fit = FALSE) {
  object <- lav_object_check_version(object)
  # partable original model
  partable <- object@ParTable[c(
    "lhs", "op", "rhs", "free", "exo", "label",
    "plabel"
  )]

  # new in 0.6-3: check for non-parameters
  nonpar.idx <- which(partable$op %in% c("==", ":=", "<", ">"))

  # always add block/group/level
  if (!is.null(object@ParTable$group)) {
    partable$group <- object@ParTable$group
  } else {
    partable$group <- rep(1L, length(partable$lhs))
    if (length(nonpar.idx) > 0L) {
      partable$group[nonpar.idx] <- 0L
    }
  }
  if (!is.null(object@ParTable$level)) {
    partable$level <- object@ParTable$level
  } else {
    partable$level <- rep(1L, length(partable$lhs))
    if (length(nonpar.idx) > 0L) {
      partable$level[nonpar.idx] <- 0L
    }
  }
  if (!is.null(object@ParTable$block)) {
    partable$block <- object@ParTable$block
  } else {
    partable$block <- rep(1L, length(partable$lhs))
    if (length(nonpar.idx) > 0L) {
      partable$block[nonpar.idx] <- 0L
    }
  }

  # TDJ: Added to prevent error when lav_partable_merge() is called below.
  #      Problematic if object@ParTable is missing one of the requested slots,
  #      which returns a NULL slot with a missing <NA> name.  For example:
  #        example(cfa)
  #        lav_partable_independence(lavdata = fit@Data, lavpta = fit@pta,
  #                                  lavoptions = lavInspect(fit, "options"))
  #     Has no "label" or "plabel" elements.
  empties <- which(sapply(partable, is.null))
  if (length(empties)) {
    partable[empties] <- NULL
  }

  if (all.free) {
    partable$user <- rep(1L, length(partable$lhs))
    non.free.idx <- which(partable$free == 0L & partable$op != "==" &
      partable$op != ":=" & partable$op != "<" &
      partable$op != ">")
    partable$free[non.free.idx] <- 1L
    partable$user[non.free.idx] <- 10L
  }

  # replace 'start' column, since lav_model will fill these in in GLIST
  partable$start <- lavParameterEstimates(object,
    remove.system.eq = FALSE,
    remove.def = FALSE,
    remove.eq = FALSE,
    remove.ineq = FALSE,
    remove.nonfree = FALSE,
    remove.unused = FALSE
  )$est

  # add new parameters, extend model
  if (is.list(add)) {
    stopifnot(
      !is.null(add$lhs),
      !is.null(add$op),
      !is.null(add$rhs)
    )
    ADD <- add
  } else if (is.character(add)) {
    ngroups <- lav_partable_ngroups(partable)
    ADD.orig <- lav_model_partable(add, ngroups = ngroups)
    ADD <- ADD.orig[, c("lhs", "op", "rhs", "user", "label")] # minimum

    # always add block/group/level
    if (!is.null(ADD.orig$group)) {
      ADD$group <- ADD.orig$group
    } else {
      ADD$group <- rep(1L, length(ADD$lhs))
    }
    if (!is.null(ADD.orig$level)) {
      ADD$level <- ADD.orig$level
    } else {
      ADD$level <- rep(1L, length(ADD$lhs))
    }
    if (!is.null(ADD.orig$block)) {
      ADD$block <- ADD.orig$block
    } else {
      ADD$block <- rep(1L, length(ADD$lhs))
    }

    remove.idx <- which(ADD$user == 0)
    if (length(remove.idx) > 0L) {
      ADD <- ADD[-remove.idx, ]
    }
    ADD$start <- rep(0, nrow(ADD))
    ADD$free <- rep(1, nrow(ADD))
    ADD$user <- rep(10, nrow(ADD))
  }

  # merge
  LIST <- lav_partable_merge(partable, ADD,
    remove.duplicated = remove.duplicated,
    warn = FALSE
  )

  # remove nonpar?
  # if(remove.nonpar) {
  #    nonpar.idx <- which(LIST$op %in% c("==", ":=", "<", ">"))
  #    if(length(nonpar.idx) > 0L) {
  #        LIST <- LIST[-nonpar.idx,]
  #    }
  # }

  # redo 'free'
  free.idx <- which(LIST$free > 0)
  LIST$free[free.idx] <- 1:length(free.idx)

  # adapt options
  lavoptions <- object@Options

  # do.fit?
  lavoptions$do.fit <- do.fit

  # needed?
  if (any(LIST$op == "~1")) lavoptions$meanstructure <- TRUE

  # switch off 'consider switching to parameterization = theta' warning
  # (modindices!)
  lavoptions$check.delta.cat.mediator <- FALSE

  FIT <- lavaan(LIST,
    slotOptions     = lavoptions,
    slotSampleStats = object@SampleStats,
    slotData        = object@Data,
    slotCache       = object@Cache,
    sloth1          = object@h1
  )

  FIT
}

# 4. catml model
lav_object_catml <- function(lavobject = NULL) {
  stopifnot(inherits(lavobject, "lavaan"))
  stopifnot(lavobject@Model@categorical)

  # extract slots
  lavdata <- lavobject@Data
  lavsamplestats <- lavobject@SampleStats
  lavoptions <- lavobject@Options
  lavpta <- lavobject@pta

  # if only categorical variables: remove thresholds and intercepts
  refit <- FALSE
  partable.catml <- parTable(lavobject)
  rm.idx <- which(partable.catml$op %in% c("|", "~1"))
  # remove also any constraints that refer to the labels that belong
  # to these intercepts/thresholds (new in 0.6-20)
  th.int.labels <- unique(
    partable.catml$label[rm.idx],
    partable.catml$plabel[rm.idx]
  )
  if (any(nchar(th.int.labels) == 0L)) {
    th.int.labels <- th.int.labels[-which(nchar(th.int.labels) == 0L)]
  }
  con.idx <- which(partable.catml$op %in% c("==", "<", ">", ":=") &
    (partable.catml$lhs %in% th.int.labels |
      partable.catml$rhs %in% th.int.labels))
  partable.catml <- partable.catml[-c(rm.idx, con.idx), ]
  # never rotate (new in 0.6-19), as we only need fit measures
  if (!is.null(partable.catml$efa)) {
    partable.catml$efa <- NULL
    partable.catml$free <- partable.catml$free.unrotated
  }

  if (!all(lavdata@ov$type == "ordered")) {
    refit <- TRUE
    partable.catml$start <- partable.catml$est
    partable.catml$se <- NULL
    partable.catml$ustart <- partable.catml$est
    for (b in seq_len(lavpta$nblocks)) {
      ov.names.num <- lavpta$vnames$ov.num[[b]]
      ov.var.idx <- which(partable.catml$op == "~~" &
        partable.catml$lhs %in% ov.names.num &
        partable.catml$lhs == partable.catml$rhs)
      partable.catml$free[ov.var.idx] <- 0L
    }
  }
  partable.catml <- lav_partable_complete(partable.catml)

  # adapt lavsamplestats
  for (g in seq_len(lavdata@ngroups)) {
    lavsamplestats@WLS.V[[g]] <- NULL
    lavsamplestats@WLS.VD[[g]] <- NULL
    COR <- lavsamplestats@cov[[g]]
    # check if COV is pd or not
    ev <- eigen(COR, symmetric = TRUE, only.values = TRUE)$values
    if (any(ev < .Machine$double.eps^(1 / 2))) {
      # not PD!
      COV <- cov2cor(lav_matrix_symmetric_force_pd(COR, tol = 1e-04))
      lavsamplestats@cov[[g]] <- COV
      lavsamplestats@var[[g]] <- diag(COV)
      refit <- TRUE
    } else {
      COV <- COR
    }

    current.warn <- lav_warn()
    if (lav_warn(FALSE)) {
      on.exit(lav_warn(current.warn), TRUE)
    }
    out <- lav_samplestats_icov(
      COV = COV, ridge = 1e-05,
      x.idx = lavsamplestats@x.idx[[g]],
      ngroups = lavdata@ngroups, g = g
    )
    lav_warn(current.warn)
    lavsamplestats@icov[[g]] <- out$icov
    lavsamplestats@cov.log.det[[g]] <- out$cov.log.det

    # NACOV <- lavsamplestats@NACOV[[g]]
    # nvar   <- nrow(COV)
    # ntotal <- nrow(NACOV)
    # pstar <- nvar*(nvar-1)/2
    # nocor <- ntotal - pstar
    # if(length(nocor) > 0L) {
    #    lavsamplestats@NACOV[[g]] <- NACOV[-seq_len(nocor),
    #                                       -seq_len(nocor)]
    # }
  }

  # adapt lavoptions
  lavoptions$estimator <- "catML"
  lavoptions$.categorical <- FALSE
  lavoptions$categorical <- FALSE
  lavoptions$correlation <- TRUE
  lavoptions$meanstructure <- FALSE
  lavoptions$conditional.x <- FALSE # fixme
  lavoptions$information <- c("expected", "expected")
  lavoptions$h1.information <- c("structured", "structured") # unlike DWLS
  lavoptions$se <- "none"
  lavoptions$test <- "standard" # always for now
  lavoptions$rotation <- "none" # new in 0.6-19
  lavoptions$baseline <- TRUE # also for RMSEA?
  if (!refit) {
    lavoptions$optim.method <- "none"
    lavoptions$optim.force.converged <- TRUE
  } else {
    lavoptions$optim.gradient <- "numerical"
  }

  # dummy fit
  FIT <- lavaan(
    slotParTable = partable.catml,
    slotSampleStats = lavsamplestats,
    slotData = lavdata,
    slotOptions = lavoptions
  )

  FIT
}

# YR 11 feb 2017: initial version

# given a parameter table (PT), extract a part of the model:
# eg.:
# - only the measurement model (with saturated latent variables)
# - only the stuctural part
# - a single measurement block
# ...

# YR 25 June 2021: - add.exo.cov = TRUE for structural model
#                  - fixed.x = FALSE/TRUE -> exo flags


# FIXME:
# - but fixed-to-zero covariances may not be present in PT...
# - if indicators are regressed on exogenous covariates, should we
#   add them here? (no for now, unless add.ind.predictors = TRUE)
# - new in 0.6-20: - check for 2nd, 3rd order lv.names...
#                  - allow for conditional.x (global SAM)
lav_partable_subset_measurement_model <- function(PT = NULL,
                                                  lv.names = NULL,
                                                  add.lv.cov = TRUE,
                                                  add.ind.predictors = FALSE,
                                                  add.idx = FALSE,
                                                  idx.only = FALSE) {
  # PT
  PT <- as.data.frame(PT, stringsAsFactors = FALSE)

  # check if we have free.unrotated column (rotation!)
  if (!is.null(PT$free.unrotated)) {
    PT$free.orig <- PT$free
    PT$free <- PT$free.unrotated
    PT$est.unrotated <- NULL
    PT$free.unrotated <- NULL
    PT$est.std <- NULL
  }

  # lavpta
  lavpta <- lav_partable_attributes(PT)

  # nblocks
  nblocks <- lavpta$nblocks
  block.values <- lav_partable_block_values(PT)

  # lv.names: list with element per block
  if (is.null(lv.names)) {
    lv.names <- lavpta$vnames$lv.regular
  } else if (!is.list(lv.names)) {
    lv.names <- rep(list(lv.names), nblocks)
  }

  # if lv.names contains a higher-order latent variable,
  # add its (latent) indicators
  for (g in 1:nblocks) {
    if (length(lavpta$vnames$lv.ind[[g]]) == 0L) {
      next
    }
    # ALL lv names
    LV.names <- lavpta$vnames$lv[[g]]

    # lv.names in this block
    this.lv <- lv.names[[g]]

    all.ind.are.observed.flag <- FALSE
    new.lv <- character(0L)
    while (!all.ind.are.observed.flag) {
      # check indicators of all this.lv
      RHS <- PT$rhs[which(PT$op == "=~" & PT$block == g &
                          PT$lhs %in% this.lv)]
      lv.idx <- which(RHS %in% LV.names)
      if (length(lv.idx) > 0L) {
        # add these 'new' ones to new.lv
        new.lv <- c(new.lv, RHS[lv.idx])
        this.lv <- RHS[lv.idx]
      } else {
        all.ind.are.observed.flag <- TRUE
      }
    }

    # update lv.names for this block
    lv.names[[g]] <- unique(c(lv.names[[g]], new.lv))
  }

  # keep rows idx
  keep.idx <- integer(0L)

  # remove not-needed measurement models
  for (g in 1:nblocks) {
    # indicators for latent variables we keep
    IND.idx <- which(PT$op == "=~" &
      PT$lhs %in% lv.names[[g]] &
      PT$block == block.values[g])
    IND <- PT$rhs[IND.idx]
    IND.plabel <- PT$plabel[IND.idx]

    # keep =~
    keep.idx <- c(keep.idx, IND.idx)

    # new in 0.6-17: indicators regressed on predictors
    if (add.ind.predictors) {
      PRED.idx <- which(PT$op == "~" &
        PT$lhs %in% IND &
        PT$block == block.values[g])
      EXTRA <- unique(PT$rhs[PRED.idx])
      keep.idx <- c(keep.idx, PRED.idx)
      # add them to IND, so we include their variances/intercepts
      IND <- c(IND, EXTRA)
    }

    # keep ~~
    OV.VAR.idx <- which(PT$op == "~~" &
      PT$lhs %in% IND &
      PT$rhs %in% IND &
      PT$block == block.values[g])
    keep.idx <- c(keep.idx, OV.VAR.idx)

    LV.VAR.idx <- which(PT$op == "~~" &
      PT$lhs %in% lv.names[[g]] &
      PT$rhs %in% lv.names[[g]] &
      PT$block == block.values[g])
    keep.idx <- c(keep.idx, LV.VAR.idx)

    # intercepts indicators
    OV.INT.idx <- which(PT$op == "~1" &
      PT$lhs %in% IND &
      PT$block == block.values[g])
    keep.idx <- c(keep.idx, OV.INT.idx)

    # intercepts latent variables
    LV.INT.idx <- which(PT$op == "~1" &
      PT$lhs %in% lv.names[[g]] &
      PT$block == block.values[g])
    keep.idx <- c(keep.idx, LV.INT.idx)

    # thresholds
    TH.idx <- which(PT$op == "|" &
      PT$lhs %in% IND &
      PT$block == block.values[g])
    keep.idx <- c(keep.idx, TH.idx)

    # scaling factors
    SC.idx <- which(PT$op == "~*~" &
      PT$lhs %in% IND &
      PT$block == block.values[g])
    keep.idx <- c(keep.idx, SC.idx)

    # defined/constraints
    if (any(PT$op %in% c("==", "<", ">", ":="))) {
      # get the 'id' numbers and the labels involved in def/constraints
      PT2 <- PT
      PT2$free <- PT$id # us 'id' numbers instead of 'free' indices
      ID <- lav_partable_constraints_label_id(PT2, def = TRUE)
      LABEL <- names(ID)

      # what are the row indices that we currently keep?
      FREE.id <- PT$id[keep.idx]
    }

    # defined parameters
    def.idx <- which(PT$op == ":=")
    if (length(def.idx) > 0L) {
      def.keep <- logical(length(def.idx))
      for (def in seq_len(length(def.idx))) {
        # rhs
        RHS.labels <- all.vars(as.formula(paste(
          "~",
          PT[def.idx[def], "rhs"]
        )))
        if (length(RHS.labels) > 0L) {
          # par id
          RHS.freeid <- ID[match(RHS.labels, LABEL)]

          # keep?
          if (all(RHS.freeid %in% FREE.id)) {
            def.keep[def] <- TRUE
          }
        } else { # only constants?
          def.keep[def] <- TRUE
        }
      }
      keep.idx <- c(keep.idx, def.idx[def.keep])
      # add 'id' numbers of := definitions that we keep
      FREE.id <- c(FREE.id, PT$id[def.idx[def.keep]])
    }

    # (in)equality constraints
    con.idx <- which(PT$op %in% c("==", "<", ">"))
    if (length(con.idx) > 0L) {
      con.keep <- logical(length(con.idx))
      for (con in seq_len(length(con.idx))) {
        lhs.keep <- FALSE
        rhs.keep <- FALSE

        # lhs
        LHS.labels <- all.vars(as.formula(paste(
          "~",
          PT[con.idx[con], "lhs"]
        )))
        if (length(LHS.labels) > 0L) {
          # par id
          LHS.freeid <- ID[match(LHS.labels, LABEL)]

          # keep?
          if (all(LHS.freeid %in% FREE.id)) {
            lhs.keep <- TRUE
          }
        } else {
          lhs.keep <- TRUE
        }

        # rhs
        RHS.labels <- all.vars(as.formula(paste(
          "~",
          PT[con.idx[con], "rhs"]
        )))
        if (length(RHS.labels) > 0L) {
          # par id
          RHS.freeid <- ID[match(RHS.labels, LABEL)]

          # keep?
          if (all(RHS.freeid %in% FREE.id)) {
            rhs.keep <- TRUE
          }
        } else {
          rhs.keep <- TRUE
        }

        if (lhs.keep && rhs.keep) {
          con.keep[con] <- TRUE
        }
      }

      keep.idx <- c(keep.idx, con.idx[con.keep])
    } # con
  } # block

  # remove any duplicated (only with higher-order factors)
  keep.idx <- keep.idx[!duplicated(keep.idx)]

  if (idx.only) {
    return(keep.idx)
  }

  PT <- PT[keep.idx, , drop = FALSE]

  # check if we have enough indicators?
  # TODO

  # add covariances among latent variables?
  if (add.lv.cov) {
    PT <- lav_partable_add_lv_cov(
      PT = PT,
      lv.names = lv.names
    )
  }

  # clean up
  PT <- lav_partable_complete(PT)

  if (add.idx) {
    attr(PT, "idx") <- keep.idx
  }

  PT
}

# NOTE: only within same level
lav_partable_add_lv_cov <- function(PT, lv.names = NULL) {
  # PT
  if (!is.data.frame(PT)) {
    PT <- as.data.frame(PT, stringsAsFactors = FALSE)
  }

  # lavpta
  lavpta <- lav_partable_attributes(PT)

  # nblocks
  nblocks <- lavpta$nblocks
  block.values <- lav_partable_block_values(PT)

  # lv.names: list with element per block
  if (is.null(lv.names)) {
    lv.names <- lavpta$vnames$lv.regular
  } else if (!is.list(lv.names)) {
    lv.names <- rep(list(lv.names), nblocks)
  }

  # check for higher-order models (new in 0.6-20)
  for (b in seq_len(nblocks)) {
    if (length(lavpta$vnames$lv.ind[[b]]) > 0L) {
      ind.idx <- which(lv.names[[b]] %in% lavpta$vnames$lv.ind[[b]])
      if (length(ind.idx) > 0L) {
        lv.names[[b]] <- lv.names[[b]][-ind.idx]
      }
    }
  }

  # remove lv.names if not present at same level/block
  if (nblocks > 1L) {
    for (b in seq_len(nblocks)) {
      rm.idx <- which(!lv.names[[b]] %in% lavpta$vnames$lv.regular[[b]])
      if (length(rm.idx) > 0L) {
        lv.names[[b]] <- lv.names[[b]][-rm.idx]
      }
    } # b
  }

  # add covariances among latent variables
  for (b in seq_len(nblocks)) {
    if (length(lv.names[[b]]) > 1L) {
      tmp <- utils::combn(lv.names[[b]], 2L)
      for (i in seq_len(ncol(tmp))) {
        # already present?
        cov1.idx <- which(PT$op == "~~" &
          PT$block == block.values[b] &
          PT$lhs == tmp[1, i] & PT$rhs == tmp[2, i])
        cov2.idx <- which(PT$op == "~~" &
          PT$block == block.values[b] &
          PT$lhs == tmp[2, i] & PT$rhs == tmp[1, i])

        # if not, add
        if (length(c(cov1.idx, cov2.idx)) == 0L) {
          ADD <- list(
            lhs = tmp[1, i],
            op = "~~",
            rhs = tmp[2, i],
            user = 3L,
            free = max(PT$free) + 1L,
            block = b
          )
          # add group column
          if (!is.null(PT$group)) {
            ADD$group <- unique(PT$block[PT$block == b])
          }
          # add level column
          if (!is.null(PT$level)) {
            ADD$level <- unique(PT$level[PT$block == b])
          }
          # add lower column
          if (!is.null(PT$lower)) {
            ADD$lower <- as.numeric(-Inf)
          }
          # add upper column
          if (!is.null(PT$upper)) {
            ADD$upper <- as.numeric(+Inf)
          }
          PT <- lav_partable_add(PT, add = ADD)
        }
      }
    } # lv.names
  } # blocks

  PT
}

# this function takes a 'full' SEM (measurement models + structural part)
# and returns only the structural part
#
# - what to do if we have no regressions among the latent variables?
#   -> we return all covariances among the latent variables
#
lav_partable_subset_structural_model <- function(PT = NULL,
                                                 add.idx = FALSE,
                                                 idx.only = FALSE,
                                                 add.exo.cov = FALSE,
                                                 fixed.x = FALSE,
                                                 conditional.x = FALSE,
                                                 free.fixed.var = FALSE,
                                                 meanstructure = FALSE) {
  # PT
  PT <- PT.orig <- as.data.frame(PT, stringsAsFactors = FALSE)

  # remove any EFA related information -- new in 0.6-18
  if (!is.null(PT$efa)) {
    PT$efa <- NULL
    PT$est.unrotated <- NULL
    seven.idx <- which(PT$user == 7L & PT$op == "~~")
    if (length(seven.idx) > 0L) {
      PT$user[seven.idx] <- 0L
      PT$free[seven.idx] <- 1L
      PT$ustart[seven.idx] <- as.numeric(NA)
      PT$est[seven.idx] <- PT$est.std[seven.idx]
    }
    PT$est.std <- NULL
  }

  # lavpta
  lavpta <- lav_partable_attributes(PT)

  # nblocks
  nblocks <- lavpta$nblocks
  block.values <- lav_partable_block_values(PT)

  # eqs.names
  eqs.x.names <- lavpta$vnames$eqs.x
  eqs.y.names <- lavpta$vnames$eqs.y
  lv.names <- lavpta$vnames$lv.regular

  # keep rows idx
  keep.idx <- integer(0L)

  # remove not-needed measurement models
  for (g in 1:nblocks) {

    # eqs.names
    eqs.names <- unique(c(
      lavpta$vnames$eqs.x[[g]],
      lavpta$vnames$eqs.y[[g]]
    ))
    if (length(eqs.names) == 0L) { # no structural model
      eqs.names <- lv.names[[g]]
    }
    # all.names <- unique(c(
    #   eqs.names,
    #   lavpta$vnames$lv.regular[[g]]
    # ))

    # regressions
    reg.idx <- which(PT$op == "~" & PT$block == block.values[g] &
      PT$lhs %in% eqs.names &
      PT$rhs %in% eqs.names)

    # the variances
    var.idx <- which(PT$op == "~~" & PT$block == block.values[g] &
      PT$lhs %in% eqs.names &
      PT$rhs %in% eqs.names &
      PT$lhs == PT$rhs)

    # optionally covariances (exo!)
    cov.idx <- which(PT$op == "~~" & PT$block == block.values[g] &
      PT$lhs %in% eqs.names &
      PT$rhs %in% eqs.names &
      PT$lhs != PT$rhs)

    # means/intercepts
    int.idx <- which(PT$op == "~1" & PT$block == block.values[g] &
      PT$lhs %in% eqs.names)

    keep.idx <- c(
      keep.idx, reg.idx, var.idx, cov.idx, int.idx
    )

    # defined/constraints
    if (any(PT$op %in% c("==", "<", ">", ":="))) {
      # get the 'id' numbers and the labels involved in def/constraints
      PT2 <- PT
      PT2$free <- PT$id # us 'id' numbers instead of 'free' indices
      ID <- lav_partable_constraints_label_id(PT2, def = TRUE)
      LABEL <- names(ID)

      # what are the row indices that we currently keep?
      FREE.id <- PT$id[keep.idx]
    }

    # defined parameters
    def.idx <- which(PT$op == ":=")
    if (length(def.idx) > 0L) {
      def.keep <- logical(length(def.idx))
      for (def in seq_len(length(def.idx))) {
        # rhs
        RHS.labels <- all.vars(as.formula(paste(
          "~",
          PT[def.idx[def], "rhs"]
        )))
        if (length(RHS.labels) > 0L) {
          # par id
          RHS.freeid <- ID[match(RHS.labels, LABEL)]

          # keep?
          if (all(RHS.freeid %in% FREE.id)) {
            def.keep[def] <- TRUE
          }
        } else { # only constants?
          def.keep[def] <- TRUE
        }
      }
      keep.idx <- c(keep.idx, def.idx[def.keep])
      # add 'id' numbers of := definitions that we keep
      FREE.id <- c(FREE.id, PT$id[def.idx[def.keep]])
    }

    # (in)equality constraints
    con.idx <- which(PT$op %in% c("==", "<", ">"))
    if (length(con.idx) > 0L) {
      con.keep <- logical(length(con.idx))
      for (con in seq_len(length(con.idx))) {
        lhs.keep <- FALSE
        rhs.keep <- FALSE

        # lhs
        LHS.labels <- all.vars(as.formula(paste(
          "~",
          PT[con.idx[con], "lhs"]
        )))
        if (length(LHS.labels) > 0L) {
          # par id
          LHS.freeid <- ID[match(LHS.labels, LABEL)]

          # keep?
          if (all(LHS.freeid %in% FREE.id)) {
            lhs.keep <- TRUE
          }
        } else {
          lhs.keep <- TRUE
        }

        # rhs
        RHS.labels <- all.vars(as.formula(paste(
          "~",
          PT[con.idx[con], "rhs"]
        )))
        if (length(RHS.labels) > 0L) {
          # par id
          RHS.freeid <- ID[match(RHS.labels, LABEL)]

          # keep?
          if (all(RHS.freeid %in% FREE.id)) {
            rhs.keep <- TRUE
          }
        } else {
          rhs.keep <- TRUE
        }

        if (lhs.keep && rhs.keep) {
          con.keep[con] <- TRUE
        }
      }

      keep.idx <- c(keep.idx, con.idx[con.keep])
    } # con
  } # block

  if (idx.only) {
    return(keep.idx)
  }

  PT <- PT[keep.idx, , drop = FALSE]

  # add any missing covariances among exogenous variables
  if (add.exo.cov) {
    if (conditional.x) {
      PT <- lav_partable_add_exo_cov(PT, ov.names.x = lavpta$vnames$ov.x)
    } else {
      PT <- lav_partable_add_exo_cov(PT)
    }
  }

  # if meanstructure, 'free' user=0 intercepts
  if (meanstructure) {
    int.idx <- which(PT$op == "~1" & PT$user == 0L & PT$free == 0L)
    if (length(int.idx) > 0L) {
      PT$free[int.idx] <- max(PT$free) + seq_len(length(int.idx))
      PT$ustart[int.idx] <- as.numeric(NA)
      PT$user[int.idx] <- 3L
    }
  }

  # if fixed.x = FALSE, remove all remaining (free) exo=1 elements
  if (!fixed.x) {
    exo.idx <- which(PT$exo != 0L)
    if (length(exo.idx) > 0L) {
      PT$exo[exo.idx] <- 0L
      PT$user[exo.idx] <- 3L
      PT$free[exo.idx] <- max(PT$free) + seq_len(length(exo.idx))
    }

  } else if (conditional.x) {
    # don't change exo column!
  } else {
    # first, wipe out exo column
    exo.idx <- which(PT$exo != 0L)
    if (length(exo.idx) > 0L) {
      PT$exo[exo.idx] <- 0L
    }

    # keep ov.x as in global model!
    for (g in 1:nblocks) {
      # ov.names.x <- lav_partable_vnames(PT,
      #   type = "ov.x",
      #   block = block.values[g]
      # )
      ov.names.x <- lavpta$vnames$ov.x[[g]]
      if (length(ov.names.x) == 0L) {
        next
      }

      # 1. variances/covariances
      exo.var.idx <- which(
        PT$op == "~~" &
          PT$block == block.values[g] &
          PT$rhs %in% ov.names.x &
          PT$lhs %in% ov.names.x &
          PT$user %in% c(0L, 3L)
      )
      if (length(exo.var.idx) > 0L) {
        PT$ustart[exo.var.idx] <- as.numeric(NA) # to be overriden
        PT$free[exo.var.idx] <- 0L
        PT$exo[exo.var.idx] <- 1L
        PT$user[exo.var.idx] <- 3L
      }

      # 2. intercepts
      exo.int.idx <- which(
        PT$op == "~1" &
          PT$block == block.values[g] &
          PT$lhs %in% ov.names.x &
          PT$user == 0L
      )
      if (length(exo.int.idx) > 0L) {
        PT$ustart[exo.int.idx] <- as.numeric(NA) # to be overriden
        PT$free[exo.int.idx] <- 0L
        PT$exo[exo.int.idx] <- 1L
        PT$user[exo.int.idx] <- 3L
      }
    } # blocks
  } # fixed.x

  # if conditional.x, check if we have 'additional' ov.x variables
  # that were not ov.x in the global model
  if (conditional.x) {
    for (b in 1:nblocks) {
      global.ov.x <- lavpta$vnames$ov.x[[b]]
      local.ov.x <- lav_partable_vnames(PT, type = "ov.x",
        block = block.values[b]
      )
      extra.idx <- which(!local.ov.x %in% global.ov.x)
      if (length(extra.idx) > 0L) {
        extra.ov.names <- local.ov.x[extra.idx]
        for (i in seq_len(length(extra.idx))) {
          ADD <- list(
            lhs = extra.ov.names[i],
            op = "~",
            rhs = global.ov.x[1],
            user = 3L,
            free = 0L,
            block = b,
            ustart = 0,
            exo = 1L
          )
          # add group column
          if (!is.null(PT$group)) {
            ADD$group <- unique(PT$block[PT$block == b])
          }
          # add level column
          if (!is.null(PT$level)) {
            ADD$level <- unique(PT$level[PT$block == b])
          }
          # add lower column
          if (!is.null(PT$lower)) {
            ADD$lower <- as.numeric(-Inf)
          }
          # add upper column
          if (!is.null(PT$upper)) {
            ADD$upper <- as.numeric(+Inf)
          }
          PT <- lav_partable_add(PT, add = ADD)
        } # i
      } # extra.idx
    } # b
  } # conditional.x

  # if free.fixed.var, free up all 'fixed (to unity)' variances
  if (free.fixed.var) {
    fixed.var.idx <- which(PT$op == "~~" & PT$lhs == PT$rhs & PT$free == 0 &
                           PT$user == 0L & PT$ustart == 1)
    if (length(fixed.var.idx) > 0L) {
      PT$free[  fixed.var.idx] <- max(PT$free) + seq_len(length(fixed.var.idx))
      PT$ustart[fixed.var.idx] <- as.numeric(NA)
    }
  }

  # clean up
  PT <- lav_partable_complete(PT)

  if (add.idx) {
    attr(PT, "idx") <- keep.idx
  }

  PT
}

# NOTE: only within same level
lav_partable_add_exo_cov <- function(PT, ov.names.x = NULL) {
  # PT
  PT <- as.data.frame(PT, stringsAsFactors = FALSE)

  # lavpta
  lavpta <- lav_partable_attributes(PT)

  # nblocks
  nblocks <- lavpta$nblocks
  block.values <- lav_partable_block_values(PT)


  # ov.names.x: list with element per block
  if (is.null(ov.names.x)) {
    ov.names.x <- lavpta$vnames$ov.x
  } else if (!is.list(ov.names.x)) {
    ov.names.x <- rep(list(ov.names.x), nblocks)
  }

  # remove ov.names.x if not present at same level/block
  if (nblocks > 1L) {
    for (b in seq_len(nblocks)) {
      rm.idx <- which(!ov.names.x[[b]] %in% lavpta$vnames$ov.x[[b]])
      if (length(rm.idx) > 0L) {
        ov.names.x[[b]] <- ov.names.x[[b]][-rm.idx]
      }
    } # b
  }

  # add covariances among latent variables
  for (b in seq_len(nblocks)) {
    if (length(ov.names.x[[b]]) > 1L) {
      tmp <- utils::combn(ov.names.x[[b]], 2L)
      for (i in seq_len(ncol(tmp))) {
        # already present?
        cov1.idx <- which(PT$op == "~~" &
          PT$block == block.values[b] &
          PT$lhs == tmp[1, i] & PT$rhs == tmp[2, i])
        cov2.idx <- which(PT$op == "~~" &
          PT$block == block.values[b] &
          PT$lhs == tmp[2, i] & PT$rhs == tmp[1, i])

        # if not, add
        if (length(c(cov1.idx, cov2.idx)) == 0L) {
          ADD <- list(
            lhs = tmp[1, i],
            op = "~~",
            rhs = tmp[2, i],
            user = 3L,
            free = max(PT$free) + 1L,
            block = b,
            ustart = as.numeric(NA)
          )
          # add group column
          if (!is.null(PT$group)) {
            ADD$group <- unique(PT$block[PT$block == b])
          }
          # add level column
          if (!is.null(PT$level)) {
            ADD$level <- unique(PT$level[PT$block == b])
          }
          # add lower column
          if (!is.null(PT$lower)) {
            ADD$lower <- as.numeric(-Inf)
          }
          # add upper column
          if (!is.null(PT$upper)) {
            ADD$upper <- as.numeric(+Inf)
          }
          PT <- lav_partable_add(PT, add = ADD)
        }
      }
    } # ov.names.x
  } # blocks

  PT
}

# add parameter bounds to the parameter table
# lavoptions$optim.bounds
lav_partable_add_bounds <- function(partable = NULL,
                                    lavh1 = NULL,
                                    lavdata = NULL,
                                    lavsamplestats = NULL,
                                    lavoptions = NULL) {
  # no support (yet) for multilevel
  if (lav_partable_nlevels(partable) > 1L) {
    return(partable)
  }

  # check optim.bounds
  if (is.null(lavoptions$optim.bounds)) {
    # <0.6-6 version
    return(partable)
  } else if (!is.null(lavoptions$samplestats) && !lavoptions$samplestats) {
    # no sample statistics
    return(partable)
  } else {
    if (!is.null(lavoptions$bounds) && lavoptions$bounds == "none") {
      # no bounds needed
      return(partable)
    }

    # no support from effect.coding (for now)
    if (!is.null(lavoptions$effect.coding) &&
      nchar(lavoptions$effect.coding[1L]) > 0L) {
      lav_msg_warn(gettext(
        "automatic bounds not available (yet) if effect.coding is used"
        ))
      return(partable)
    }

    optim.bounds <- lavoptions$optim.bounds

    # check the elements
    if (is.null(optim.bounds$lower)) {
      optim.bounds$lower <- character(0L)
    } else {
      optim.bounds$lower <- as.character(optim.bounds$lower)
    }
    if (is.null(optim.bounds$upper)) {
      optim.bounds$upper <- character(0L)
    } else {
      optim.bounds$upper <- as.character(optim.bounds$upper)
    }

    if (is.null(optim.bounds$min.reliability.marker)) {
      optim.bounds$min.reliability.marker <- 0.0
    } else {
      if (optim.bounds$min.reliability.marker < 0 ||
        optim.bounds$min.reliability.marker > 1.0) {
        lav_msg_stop(gettextf(
          "optim.bounds$min.reliability.marker is out of range: %s",
          optim.bounds$min.reliability.marker
        ))
      }
    }

    if (is.null(optim.bounds$min.var.ov)) {
      optim.bounds$min.var.ov <- -Inf
    }

    if (is.null(optim.bounds$min.var.lv.exo)) {
      optim.bounds$min.var.lv.exo <- 0.0
    }

    if (is.null(optim.bounds$min.var.lv.endo)) {
      optim.bounds$min.var.lv.endo <- 0.0
    }

    if (is.null(optim.bounds$max.r2.lv.endo)) {
      optim.bounds$max.r2.lv.endo <- 1.0
    }

    if (is.null(optim.bounds$lower.factor)) {
      optim.bounds$lower.factor <- rep(1.0, length(optim.bounds$lower))
    } else {
      if (length(optim.bounds$lower.factor) == 1L &&
        is.numeric(optim.bounds$lower.factor)) {
        optim.bounds$lower.factor <- rep(
          optim.bounds$lower.factor,
          length(optim.bounds$lower)
        )
      } else if (length(optim.bounds$lower.factor) !=
        length(optim.bounds$lower)) {
        lav_msg_stop(
          gettext("length(optim.bounds$lower.factor) is not equal to
                  length(optim.bounds$lower)")
        )
      }
    }
    lower.factor <- optim.bounds$lower.factor

    if (is.null(optim.bounds$upper.factor)) {
      optim.bounds$upper.factor <- rep(1.0, length(optim.bounds$upper))
    } else {
      if (length(optim.bounds$upper.factor) == 1L &&
        is.numeric(optim.bounds$upper.factor)) {
        optim.bounds$upper.factor <- rep(
          optim.bounds$upper.factor,
          length(optim.bounds$upper)
        )
      } else if (length(optim.bounds$upper.factor) !=
        length(optim.bounds$upper)) {
        lav_msg_stop(
          gettext("length(optim.bounds$lower.factor) is not equal to
                  length(optim.bounds$upper)")
        )
      }
    }
    upper.factor <- optim.bounds$upper.factor
  }

  # new in 0.6-17: check if we have theta parameterization
  theta.parameterization.flag <- FALSE
  if (any(partable$op == "~*~") && lavoptions$parameterization == "theta") {
    # some fixed-to-1 theta elements?
    ov.scaled <- partable$lhs[partable$op == "~*~"]
    ov.var.idx <- which(partable$op == "~~" &
      partable$lhs %in% ov.scaled &
      partable$free == 0L &
      partable$ustart == 1)
    if (length(ov.var.idx) > 0L) {
      theta.parameterization.flag <- TRUE
      theta.parameterization.names <- partable$lhs[ov.var.idx]
    }
  }

  # shortcut
  REL <- optim.bounds$min.reliability.marker

  # nothing to do
  if (length(optim.bounds$lower) == 0L &&
    length(optim.bounds$upper) == 0L) {
    return(partable)
  } else {
    # we compute ALL bounds, then we select what we need
    # (otherwise, we can not use the 'factor')

    if (!is.null(partable$lower)) {
      lower.user <- partable$lower
    } else {
      partable$lower <- lower.user <- rep(-Inf, length(partable$lhs))
    }
    if (!is.null(partable$upper)) {
      upper.user <- partable$upper
    } else {
      partable$upper <- upper.user <- rep(+Inf, length(partable$lhs))
    }

    # the 'automatic' bounds
    lower.auto <- rep(-Inf, length(partable$lhs))
    upper.auto <- rep(+Inf, length(partable$lhs))
  }

  lavpta <- lav_partable_attributes(partable)

  # check blocks
  if (is.null(partable$block)) {
    partable$block <- rep(1L, length(partable$lhs))
  }
  block.values <- lav_partable_block_values(partable)

  # check groups
  if (is.null(partable$group)) {
    partable$group <- rep(1L, length(partable$lhs))
  }
  group.values <- lav_partable_group_values(partable)
  ngroups <- length(group.values)

  # compute bounds per group ### TODO: add levels/classes/...
  b <- 0L
  for (g in seq_len(ngroups)) {
    # next block
    b <- b + 1L

    # for this block
    ov.names <- lavpta$vnames$ov[[b]]
    lv.names <- lavpta$vnames$lv[[b]]
    lv.names.x <- lavpta$vnames$lv.x[[b]]
    if (length(lv.names.x) > 0L) {
      lv.names.endo <- lv.names[!lv.names %in% lv.names.x]
    } else {
      lv.names.endo <- lv.names
    }
    lv.marker <- lavpta$vnames$lv.marker[[b]]

    # OV.VAR for this group
    if (lavsamplestats@missing.flag && lavdata@nlevels == 1L) {
      if (!is.null(lavh1$implied$cov[[g]])) {
        OV.VAR <- diag(lavh1$implied$cov[[g]])
      } else {
        OV.VAR <- diag(lavsamplestats@missing.h1[[g]]$sigma)
      }
    } else {
      if (lavoptions$conditional.x) {
        OV.VAR <- diag(lavsamplestats@res.cov[[g]])
      } else {
        OV.VAR <- diag(lavsamplestats@cov[[g]])
      }
    }

    # new in 0.6-17: increase observed variances for 'scaled' parameters
    # if theta parameterization
    if (theta.parameterization.flag) {
      sc.idx <- match(theta.parameterization.names, ov.names)
      OV.VAR[sc.idx] <- OV.VAR[sc.idx] / REL
    }


    # we 'process' the parameters per 'type', so we can choose
    # to apply (or not) upper/lower bounds for each type separately

    ################################
    ## 1. (residual) ov variances ##
    ################################
    par.idx <- which(partable$group == group.values[g] &
      partable$op == "~~" &
      partable$lhs %in% ov.names &
      partable$lhs == partable$rhs)

    if (length(par.idx) > 0L) {
      # lower == 0
      lower.auto[par.idx] <- 0

      # upper == var(ov)
      var.idx <- match(partable$lhs[par.idx], ov.names)
      upper.auto[par.idx] <- OV.VAR[var.idx]

      # if reliability > 0, adapt marker indicators only
      if (REL > 0) {
        marker.idx <- which(partable$group == group.values[g] &
          partable$op == "~~" &
          partable$lhs %in% lv.marker &
          partable$lhs == partable$rhs)
        marker.var.idx <- match(partable$lhs[marker.idx], ov.names)

        # upper = (1-REL)*OVAR
        upper.auto[marker.idx] <- (1 - REL) * OV.VAR[marker.var.idx]
      }

      # range
      bound.range <- upper.auto[par.idx] - pmax(lower.auto[par.idx], 0)

      # enlarge lower?
      if ("ov.var" %in% optim.bounds$lower) {
        factor <- lower.factor[which(optim.bounds$lower == "ov.var")]
        if (is.finite(factor) && factor != 1.0) {
          new.range <- bound.range * factor
          diff <- abs(new.range - bound.range)
          lower.auto[par.idx] <- lower.auto[par.idx] - diff
        }
      }

      # enlarge upper?
      if ("ov.var" %in% optim.bounds$upper) {
        factor <- upper.factor[which(optim.bounds$upper == "ov.var")]
        if (is.finite(factor) && factor != 1.0) {
          new.range <- bound.range * factor
          diff <- abs(new.range - bound.range)
          upper.auto[par.idx] <- upper.auto[par.idx] + diff
        } else if (is.finite(factor) && factor == 1.0) {
          # new in 0.6-20
          # enlarge anyway, but only with 0.5%
          # this is in particular useful for exogenous variances, otherwise,
          # they will always end up on the boundary
          new.range <- bound.range * 1.005
          diff <- abs(new.range - bound.range)
          upper.auto[par.idx] <- upper.auto[par.idx] + diff
        }
      }

      # min.var.ov?
      min.idx <- which(lower.auto[par.idx] < optim.bounds$min.var.ov)
      if (length(min.idx) > 0L) {
        lower.auto[par.idx[min.idx]] <- optim.bounds$min.var.ov
      }

      # requested?
      if ("ov.var" %in% optim.bounds$lower) {
        partable$lower[par.idx] <- lower.auto[par.idx]
      }
      if ("ov.var" %in% optim.bounds$upper) {
        partable$upper[par.idx] <- upper.auto[par.idx]
      }
    } # (res) ov variances

    ################################
    ## 2. (residual) lv variances ##
    ################################

    # first collect lower/upper bounds for TOTAL variances in lv.names
    LV.VAR.LB <- numeric(length(lv.names))
    LV.VAR.UB <- numeric(length(lv.names))

    if (lavoptions$std.lv) {
      LV.VAR.LB <- rep(1.0, length(lv.names))
      LV.VAR.UB <- rep(1.0, length(lv.names))
    } else {
      for (i in seq_len(length(lv.names))) {
        this.lv.name <- lv.names[i]
        this.lv.marker <- lv.marker[i]

        if (nchar(this.lv.marker) > 0L && this.lv.marker %in% ov.names) {
          marker.var <- OV.VAR[match(this.lv.marker, ov.names)]
          LOWER <- marker.var - (1 - REL) * marker.var
          LV.VAR.LB[i] <- max(LOWER, optim.bounds$min.var.lv.exo)
          # LV.VAR.UB[i] <- marker.var - REL*marker.var
          LV.VAR.UB[i] <- marker.var

          # new in 0.6-17
          if (theta.parameterization.flag) {
            LV.VAR.LB[i] <- REL
          }
        } else {
          LV.VAR.LB[i] <- optim.bounds$min.var.lv.exo
          LV.VAR.UB[i] <- max(OV.VAR)
        }
      }
    }

    # use these bounds for the free parameters
    par.idx <- which(partable$group == group.values[g] &
      partable$op == "~~" &
      partable$lhs %in% lv.names &
      partable$lhs == partable$rhs)

    if (length(par.idx) > 0L) {
      # adjust for endogenenous lv
      LV.VAR.LB2 <- LV.VAR.LB
      endo.idx <- which(lv.names %in% lv.names.endo)
      if (length(endo.idx) > 0L) {
        LV.VAR.LB2[endo.idx] <- optim.bounds$min.var.lv.endo
        if (optim.bounds$max.r2.lv.endo != 1) {
          LV.VAR.LB2[endo.idx] <- (1 - optim.bounds$max.r2.lv.endo) * LV.VAR.UB[endo.idx]
        }
      }
      exo.idx <- which(!lv.names %in% lv.names.endo)
      if (length(exo.idx) > 0L && optim.bounds$min.var.lv.exo != 0) {
        LV.VAR.LB2[exo.idx] <- optim.bounds$min.var.lv.exo
      }

      lower.auto[par.idx] <- LV.VAR.LB2[match(
        partable$lhs[par.idx],
        lv.names
      )]
      upper.auto[par.idx] <- LV.VAR.UB[match(
        partable$lhs[par.idx],
        lv.names
      )]

      # range
      bound.range <- upper.auto[par.idx] - pmax(lower.auto[par.idx], 0)

      # enlarge lower?
      if ("lv.var" %in% optim.bounds$lower) {
        factor <- lower.factor[which(optim.bounds$lower == "lv.var")]
        if (is.finite(factor) && factor != 1.0) {
          new.range <- bound.range * factor
          diff <- abs(new.range - bound.range)
          lower.auto[par.idx] <- lower.auto[par.idx] - diff
        }
      }

      # enlarge upper?
      if ("lv.var" %in% optim.bounds$upper) {
        factor <- upper.factor[which(optim.bounds$upper == "lv.var")]
        if (is.finite(factor) && factor != 1.0) {
          new.range <- bound.range * factor
          diff <- abs(new.range - bound.range)
          upper.auto[par.idx] <- upper.auto[par.idx] + diff
        }
      }

      # requested?
      if ("lv.var" %in% optim.bounds$lower) {
        partable$lower[par.idx] <- lower.auto[par.idx]
      }
      if ("lv.var" %in% optim.bounds$upper) {
        partable$upper[par.idx] <- upper.auto[par.idx]
      }
    } # lv variances


    #############################################
    ## 3. factor loadings (ov indicators only) ##
    #############################################

    # lambda_p^(u) = sqrt( upper(res.var.indicators_p) /
    #                      lower(var.factor) )

    ov.ind.names <- lavpta$vnames$ov.ind[[b]]
    par.idx <- which(partable$group == group.values[g] &
      partable$op == "=~" &
      partable$lhs %in% lv.names &
      partable$rhs %in% ov.ind.names)

    if (length(par.idx) > 0L) {
      # if negative LV variances are allowed (due to factor > 1)
      # make them equal to zero
      LV.VAR.LB[LV.VAR.LB < 0] <- 0.0

      var.all <- OV.VAR[match(partable$rhs[par.idx], ov.names)]
      tmp <- LV.VAR.LB[match(partable$lhs[par.idx], lv.names)]
      tmp[is.na(tmp)] <- 0 # just in case...
      lower.auto[par.idx] <- -1 * sqrt(var.all / tmp) # -Inf if tmp==0
      upper.auto[par.idx] <- +1 * sqrt(var.all / tmp) # +Inf if tmp==0

      # if std.lv = TRUE, force 'first' loading to be positive?
      # if(lavoptions$std.lv) {
      #    # get index 'first' indicators
      #    first.idx <- which(!duplicated(partable$lhs[par.idx]))
      #    lower.auto[par.idx][first.idx] <- 0
      # }

      # range
      bound.range <- upper.auto[par.idx] - lower.auto[par.idx]

      # enlarge lower?
      if ("loadings" %in% optim.bounds$lower) {
        factor <- lower.factor[which(optim.bounds$lower == "loadings")]
        if (is.finite(factor) && factor != 1.0) {
          new.range <- bound.range * factor
          ok.idx <- is.finite(new.range)
          if (length(ok.idx) > 0L) {
            diff <- abs(new.range[ok.idx] - bound.range[ok.idx])
            lower.auto[par.idx][ok.idx] <-
              lower.auto[par.idx][ok.idx] - diff
          }
        }
      }

      # enlarge upper?
      if ("loadings" %in% optim.bounds$upper) {
        factor <- upper.factor[which(optim.bounds$upper == "loadings")]
        if (is.finite(factor) && factor != 1.0) {
          new.range <- bound.range * factor
          ok.idx <- is.finite(new.range)
          if (length(ok.idx) > 0L) {
            diff <- abs(new.range[ok.idx] - bound.range[ok.idx])
            upper.auto[par.idx][ok.idx] <-
              upper.auto[par.idx][ok.idx] + diff
          }
        }
      }



      # requested?
      if ("loadings" %in% optim.bounds$lower) {
        partable$lower[par.idx] <- lower.auto[par.idx]
      }
      if ("loadings" %in% optim.bounds$upper) {
        partable$upper[par.idx] <- upper.auto[par.idx]
      }
    } # lambda


    ####################
    ## 4. covariances ##
    ####################

    # | sqrt(var(x)) sqrt(var(y)) | <= cov(x,y)

    par.idx <- which(partable$group == group.values[g] &
      partable$op == "~~" &
      partable$lhs != partable$rhs)

    if (length(par.idx) > 0L) {
      for (i in seq_len(length(par.idx))) {
        # this lhs/rhs
        this.lhs <- partable$lhs[par.idx[i]]
        this.rhs <- partable$rhs[par.idx[i]]

        # 2 possibilities:
        # - variances are free parameters
        # - variances are fixed (eg std.lv = TRUE)

        # var idx
        lhs.var.idx <- which(partable$group == group.values[g] &
          partable$op == "~~" &
          partable$lhs == this.lhs &
          partable$lhs == partable$rhs)
        rhs.var.idx <- which(partable$group == group.values[g] &
          partable$op == "~~" &
          partable$lhs == this.rhs &
          partable$lhs == partable$rhs)
        # upper bounds
        lhs.upper <- upper.auto[lhs.var.idx]
        rhs.upper <- upper.auto[rhs.var.idx]

        # compute upper bounds for this cov (assuming >0 vars)
        if (is.finite(lhs.upper) && is.finite(rhs.upper)) {
          upper.cov <- sqrt(lhs.upper) * sqrt(rhs.upper)
          upper.auto[par.idx[i]] <- +1 * upper.cov
          lower.auto[par.idx[i]] <- -1 * upper.cov
        }
      }

      # range
      bound.range <- upper.auto[par.idx] - lower.auto[par.idx]

      # enlarge lower?
      if ("covariances" %in% optim.bounds$lower) {
        factor <-
          lower.factor[which(optim.bounds$lower == "covariances")]
        if (is.finite(factor) && factor != 1.0) {
          new.range <- bound.range * factor
          ok.idx <- is.finite(new.range)
          if (length(ok.idx) > 0L) {
            diff <- new.range[ok.idx] - bound.range[ok.idx]
            lower.auto[par.idx][ok.idx] <-
              lower.auto[par.idx][ok.idx] - diff
          }
        }
      }

      # enlarge upper?
      if ("covariances" %in% optim.bounds$upper) {
        factor <-
          upper.factor[which(optim.bounds$upper == "covariances")]
        if (is.finite(factor) && factor != 1.0) {
          new.range <- bound.range * factor
          ok.idx <- is.finite(new.range)
          if (length(ok.idx) > 0L) {
            diff <- new.range[ok.idx] - bound.range[ok.idx]
            upper.auto[par.idx][ok.idx] <-
              upper.auto[par.idx][ok.idx] + diff
          }
        }
      }

      # requested?
      if ("covariances" %in% optim.bounds$lower) {
        partable$lower[par.idx] <- lower.auto[par.idx]
      }
      if ("covariances" %in% optim.bounds$upper) {
        partable$upper[par.idx] <- upper.auto[par.idx]
      }
    } # covariances
  } # g

  # overwrite with lower.user (except -Inf)
  not.inf.idx <- which(lower.user > -Inf)
  if (length(not.inf.idx) > 0L) {
    partable$lower[not.inf.idx] <- lower.user[not.inf.idx]
  }

  # overwrite with upper.user (except +Inf)
  not.inf.idx <- which(upper.user < +Inf)
  if (length(not.inf.idx) > 0L) {
    partable$upper[not.inf.idx] <- upper.user[not.inf.idx]
  }

  # non-free
  non.free.idx <- which(partable$free == 0L)
  if (length(non.free.idx) > 0L && !is.null(partable$ustart)) {
    partable$lower[non.free.idx] <- partable$ustart[non.free.idx]
    partable$upper[non.free.idx] <- partable$ustart[non.free.idx]
  }

  partable
}

# This function was written in January 2012 -- Yves Rosseel
# First success: Friday 20 Jan 2012: the standard errors for
#                thresholds and polychoric correlations (in an
#                unrestricted/saturated model) are spot on!
# Second success: Saturday 9 June 2012: support for mixed (ordinal + metric)
#                 variables; thanks to the delta method to get the ACOV
#                 right (see H matrix)
# Third success: Monday 2 July 2012: support for fixed.x covariates
#
# Friday 13 July 2012: merge exo + non-exo code
# Monday 16 July 2012: fixed sign numeric in WLS.W; I think we got it right now

# YR 26 Nov 2015: move step1 + step2 to external functions
#
muthen1984 <- function(Data = NULL,
                       ov.names = NULL,
                       ov.types = NULL,
                       ov.levels = NULL,
                       ov.names.x = character(0L),
                       eXo = NULL,
                       wt = NULL,
                       WLS.W = TRUE,
                       zero.add = c(0.5, 0.0),
                       zero.keep.margins = TRUE,
                       zero.cell.warn = FALSE,
                       zero.cell.tables = TRUE,
                       allow.empty.cell = TRUE,
                       group = 1L) { # group only for error messages

  # just in case Data is a vector
  Data <- as.matrix(Data)

  nvar <- NCOL(Data)
  N <- NROW(Data)
  num.idx <- which(ov.types == "numeric")
  ord.idx <- which(ov.types == "ordered")
  nexo <- length(ov.names.x)
  if (nexo > 0L) stopifnot(NCOL(eXo) == nexo)
  pstar <- nvar * (nvar - 1) / 2

  if (lav_verbose()) {
    cat("\nPreparing for WLS estimation -- STEP 1 + 2\n")
    cat("Number of endogenous variables: ", nvar, "\n")
    cat("Endogenous variable names:\n")
    print(ov.names)
    cat("\n")
    cat("Endogenous ov types:\n")
    print(ov.types)
    cat("\n")
    cat("Endogenous ov levels:\n ")
    print(ov.levels)
    cat("\n")
    cat("Number of exogenous variables: ", nexo, "\n")
    cat("Exogenous variable names:\n")
    print(ov.names.x)
    cat("\n")
  }

  step1 <- lav_samplestats_step1(
    Y = Data, wt = wt, ov.names = ov.names,
    ov.types = ov.types, ov.levels = ov.levels, ov.names.x = ov.names.x,
    eXo = eXo, scores.flag = WLS.W, allow.empty.cell = allow.empty.cell, group = group
  )

  FIT <- step1$FIT
  TH <- step1$TH
  TH.NOX <- step1$TH.NOX
  TH.IDX <- step1$TH.IDX
  TH.NAMES <- step1$TH.NAMES
  VAR <- step1$VAR
  SLOPES <- step1$SLOPES
  SC.TH <- step1$SC.TH
  SC.SL <- step1$SC.SL
  SC.VAR <- step1$SC.VAR
  th.start.idx <- step1$th.start.idx
  th.end.idx <- step1$th.end.idx

  # rm SC.VAR columns from ordinal variables
  if (WLS.W && length(ord.idx) > 0L) {
    SC.VAR <- SC.VAR[, -ord.idx, drop = FALSE]
  }


  if (lav_verbose()) {
    cat("STEP 1: univariate statistics\n")
    cat("Threshold + means:\n")
    TTHH <- unlist(TH)
    names(TTHH) <- unlist(TH.NAMES)
    print(TTHH)
    cat("Slopes (if any):\n")
    colnames(SLOPES) <- ov.names.x
    rownames(SLOPES) <- ov.names
    print(SLOPES)
    cat("Variances:\n")
    names(VAR) <- ov.names
    print(unlist(VAR))
  }

  # stage two -- correlations

  if (lav_verbose()) cat("\n\nSTEP 2: covariances/correlations:\n")
  COR <- lav_samplestats_step2(
    UNI = FIT, wt = wt, ov.names = ov.names,
    zero.add = zero.add,
    zero.keep.margins = zero.keep.margins,
    zero.cell.warn = zero.cell.warn,
    zero.cell.tables = zero.cell.tables
  )
  empty.cell.tables <- attr(COR, "zero.cell.tables")
  attr(COR, "zero.cell.tables") <- NULL

  if (lav_verbose()) {
    colnames(COR) <- rownames(COR) <- ov.names
    print(COR)
  }

  if (!WLS.W) { # we do not need the asymptotic variance matrix
    if (any("numeric" %in% ov.types)) {
      COV <- lav_cor2cov(R = COR, sds = sqrt(unlist(VAR)))
    } else {
      COV <- COR
    }
    out <- list(
      TH = TH, SLOPES = SLOPES, VAR = VAR, COR = COR, COV = COV,
      SC = NULL, TH.NOX = TH.NOX, TH.NAMES = TH.NAMES, TH.IDX = TH.IDX,
      INNER = NULL, A11 = NULL, A12 = NULL, A21 = NULL, A22 = NULL,
      WLS.W = NULL, H = NULL, zero.cell.tables = matrix("", 0, 2)
    )
    return(out)
  }


  # stage three -- WLS.W
  SC.COR <- matrix(0, N, pstar)
  PSTAR <- matrix(0, nvar, nvar)
  PSTAR[lav_matrix_vech_idx(nvar, diagonal = FALSE)] <- 1:pstar

  A11.size <- NCOL(SC.TH) + NCOL(SC.SL) + NCOL(SC.VAR)








  # A21
  A21 <- matrix(0, pstar, A11.size)
  H22 <- diag(pstar) # for the delta rule
  H21 <- matrix(0, pstar, A11.size)
  # for this one, we need new scores: for each F_ij (cor), the
  # scores with respect to the TH, VAR, ...
  for (j in seq_len(nvar - 1L)) {
    for (i in (j + 1L):nvar) {
      pstar.idx <- PSTAR[i, j]
      th.idx_i <- th.start.idx[i]:th.end.idx[i]
      th.idx_j <- th.start.idx[j]:th.end.idx[j]
      if (nexo > 0L) {
        sl.idx_i <- NCOL(SC.TH) + seq(i, by = nvar, length.out = nexo)
        sl.idx_j <- NCOL(SC.TH) + seq(j, by = nvar, length.out = nexo)

        var.idx_i <- NCOL(SC.TH) + NCOL(SC.SL) + match(i, num.idx)
        var.idx_j <- NCOL(SC.TH) + NCOL(SC.SL) + match(j, num.idx)
      } else {
        var.idx_i <- NCOL(SC.TH) + match(i, num.idx)
        var.idx_j <- NCOL(SC.TH) + match(j, num.idx)
      }
      if (ov.types[i] == "numeric" && ov.types[j] == "numeric") {
        SC.COR.UNI <- lav_bvreg_cor_scores(
          rho = COR[i, j],
          fit.y1 = FIT[[i]],
          fit.y2 = FIT[[j]],
          wt = wt
        )

        # RHO
        if (is.null(wt)) {
          SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho
        } else {
          SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho / wt # unweight
        }

        # TH
        A21[pstar.idx, th.idx_i] <-
          lav_matrix_crossprod(
            SC.COR[, pstar.idx],
            SC.COR.UNI$dx.mu.y1
          )
        A21[pstar.idx, th.idx_j] <-
          lav_matrix_crossprod(
            SC.COR[, pstar.idx],
            SC.COR.UNI$dx.mu.y2
          )
        # SL
        if (nexo > 0L) {
          A21[pstar.idx, sl.idx_i] <-
            lav_matrix_crossprod(
              SC.COR[, pstar.idx],
              SC.COR.UNI$dx.sl.y1
            )
          A21[pstar.idx, sl.idx_j] <-
            lav_matrix_crossprod(
              SC.COR[, pstar.idx],
              SC.COR.UNI$dx.sl.y2
            )
        }
        # VAR
        A21[pstar.idx, var.idx_i] <-
          lav_matrix_crossprod(
            SC.COR[, pstar.idx],
            SC.COR.UNI$dx.var.y1
          )
        A21[pstar.idx, var.idx_j] <-
          lav_matrix_crossprod(
            SC.COR[, pstar.idx],
            SC.COR.UNI$dx.var.y2
          )
        # H21 only needed for VAR
        H21[pstar.idx, var.idx_i] <-
          (sqrt(VAR[j]) * COR[i, j]) / (2 * sqrt(VAR[i]))
        H21[pstar.idx, var.idx_j] <-
          (sqrt(VAR[i]) * COR[i, j]) / (2 * sqrt(VAR[j]))
        H22[pstar.idx, pstar.idx] <- sqrt(VAR[i]) * sqrt(VAR[j])
      } else if (ov.types[i] == "numeric" && ov.types[j] == "ordered") {
        SC.COR.UNI <- lav_bvmix_cor_scores(
          rho = COR[i, j],
          fit.y1 = FIT[[i]],
          fit.y2 = FIT[[j]],
          wt = wt
        )
        # RHO
        if (is.null(wt)) {
          SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho
        } else {
          SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho / wt # unweight
        }

        # TH
        A21[pstar.idx, th.idx_i] <-
          lav_matrix_crossprod(
            SC.COR[, pstar.idx],
            SC.COR.UNI$dx.mu.y1
          )
        A21[pstar.idx, th.idx_j] <-
          lav_matrix_crossprod(
            SC.COR[, pstar.idx],
            SC.COR.UNI$dx.th.y2
          )
        # SL
        if (nexo > 0L) {
          A21[pstar.idx, sl.idx_i] <-
            lav_matrix_crossprod(
              SC.COR[, pstar.idx],
              SC.COR.UNI$dx.sl.y1
            )
          A21[pstar.idx, sl.idx_j] <-
            lav_matrix_crossprod(
              SC.COR[, pstar.idx],
              SC.COR.UNI$dx.sl.y2
            )
        }
        # VAR
        A21[pstar.idx, var.idx_i] <-
          lav_matrix_crossprod(
            SC.COR[, pstar.idx],
            SC.COR.UNI$dx.var.y1
          )
        # H21 only need for VAR
        H21[pstar.idx, var.idx_i] <- COR[i, j] / (2 * sqrt(VAR[i]))
        H22[pstar.idx, pstar.idx] <- sqrt(VAR[i])
      } else if (ov.types[j] == "numeric" && ov.types[i] == "ordered") {
        SC.COR.UNI <- lav_bvmix_cor_scores(
          rho = COR[i, j],
          fit.y1 = FIT[[j]],
          fit.y2 = FIT[[i]],
          wt = wt
        )
        # RHO
        if (is.null(wt)) {
          SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho
        } else {
          SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho / wt # unweight
        }

        # TH
        A21[pstar.idx, th.idx_j] <-
          lav_matrix_crossprod(
            SC.COR[, pstar.idx],
            SC.COR.UNI$dx.mu.y1
          )
        A21[pstar.idx, th.idx_i] <-
          lav_matrix_crossprod(
            SC.COR[, pstar.idx],
            SC.COR.UNI$dx.th.y2
          )
        # SL
        if (nexo > 0L) {
          A21[pstar.idx, sl.idx_j] <-
            lav_matrix_crossprod(
              SC.COR[, pstar.idx],
              SC.COR.UNI$dx.sl.y1
            )
          A21[pstar.idx, sl.idx_i] <-
            lav_matrix_crossprod(
              SC.COR[, pstar.idx],
              SC.COR.UNI$dx.sl.y2
            )
        }
        # VAR
        A21[pstar.idx, var.idx_j] <-
          lav_matrix_crossprod(
            SC.COR[, pstar.idx],
            SC.COR.UNI$dx.var.y1
          )
        # H21 only for VAR
        H21[pstar.idx, var.idx_j] <- COR[i, j] / (2 * sqrt(VAR[j]))
        H22[pstar.idx, pstar.idx] <- sqrt(VAR[j])
      } else if (ov.types[i] == "ordered" && ov.types[j] == "ordered") {
        # polychoric correlation
        SC.COR.UNI <- lav_bvord_cor_scores(
          rho = COR[i, j],
          fit.y1 = FIT[[i]],
          fit.y2 = FIT[[j]],
          wt = wt
        )
        # RHO
        if (is.null(wt)) {
          SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho
        } else {
          SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho / wt # unweight
        }

        # TH
        A21[pstar.idx, th.idx_i] <-
          lav_matrix_crossprod(
            SC.COR[, pstar.idx],
            SC.COR.UNI$dx.th.y1
          )
        A21[pstar.idx, th.idx_j] <-
          lav_matrix_crossprod(
            SC.COR[, pstar.idx],
            SC.COR.UNI$dx.th.y2
          )
        # SL
        if (nexo > 0L) {
          A21[pstar.idx, sl.idx_i] <-
            lav_matrix_crossprod(
              SC.COR[, pstar.idx],
              SC.COR.UNI$dx.sl.y1
            )
          A21[pstar.idx, sl.idx_j] <-
            lav_matrix_crossprod(
              SC.COR[, pstar.idx],
              SC.COR.UNI$dx.sl.y2
            )
        }
        # NO VAR
      }
    }
  }
  if (!is.null(wt)) {
    SC.COR <- SC.COR * wt # reweight
  }





  # stage three

  SC <- cbind(SC.TH, SC.SL, SC.VAR, SC.COR)
  INNER <- lav_matrix_crossprod(SC)

  # A11
  # new approach (2 June 2012): A11 is just a 'sparse' version of
  # (the left upper block of) INNER
  A11 <- matrix(0, A11.size, A11.size)
  if (!is.null(wt)) {
    INNER2 <- lav_matrix_crossprod(SC / wt, SC)
  } else {
    INNER2 <- INNER
  }
  for (i in 1:nvar) {
    th.idx <- th.start.idx[i]:th.end.idx[i]
    sl.idx <- integer(0L)
    var.idx <- integer(0L)
    if (nexo > 0L) {
      sl.idx <- NCOL(SC.TH) + seq(i, by = nvar, length.out = nexo)
      # sl.end.idx <- (i*nexo); sl.start.idx <- (i-1L)*nexo + 1L
      # sl.idx <- NCOL(SC.TH) + (sl.start.idx:sl.end.idx)
    }
    if (ov.types[i] == "numeric") {
      var.idx <- NCOL(SC.TH) + NCOL(SC.SL) + match(i, num.idx)
    }
    a11.idx <- c(th.idx, sl.idx, var.idx)
    A11[a11.idx, a11.idx] <- INNER2[a11.idx, a11.idx]
  }

  ##### DEBUG ######
  #### for numeric VAR only, use hessian to get better residual var value
  ####
  # for(i in 1:nvar) {
  #     if(ov.types[i] == "numeric") {
  #         tmp.npar <- FIT[[i]]$npar
  #         e.var <- FIT[[i]]$theta[ tmp.npar ]
  #         sq.e.var <- sqrt(e.var)
  #         sq.e.var6 <- sq.e.var*sq.e.var*sq.e.var*sq.e.var*sq.e.var*sq.e.var
  #         dx2.var <- N/(2*e.var*e.var) - 1/sq.e.var6 * (e.var * N)
  #
  #         var.idx <- NCOL(SC.TH) + NCOL(SC.SL) + match(i, num.idx)
  #         A11[var.idx, var.idx] <- -1 * dx2.var
  #     }
  # }
  ################
  ################

  # A22 (diagonal)
  A22 <- matrix(0, pstar, pstar)
  for (i in seq_len(pstar)) {
    if (is.null(wt)) {
      A22[i, i] <- sum(SC.COR[, i] * SC.COR[, i], na.rm = TRUE)
    } else {
      A22[i, i] <- sum(SC.COR[, i] * SC.COR[, i] / wt, na.rm = TRUE)
    }
  }

  # A12 (zero)
  A12 <- matrix(0, NROW(A11), NCOL(A22))


  # B <- rbind( cbind(A11,A12),
  #            cbind(A21,A22) )

  # we invert B as a block-triangular matrix (0.5-23)
  #
  # B.inv = A11^{-1}                   0
  #         -A22^{-1} A21 A11^{-1}     A22^{-1}
  #

  # invert A
  A11.inv <- try(solve(A11), silent = TRUE)
  if (inherits(A11.inv, "try-error")) {
    # brute force
    A11.inv <- MASS::ginv(A11)
    lav_msg_warn(gettext("trouble constructing W matrix;
                         used generalized inverse for A11 submatrix"))
  }

  # invert
  da22 <- diag(A22)
  if (any(da22 == 0)) {
    lav_msg_warn(gettext("trouble constructing W matrix;
                         used generalized inverse for A22 submatrix"))
    A22.inv <- MASS::ginv(A22)
  } else {
    A22.inv <- A22
    diag(A22.inv) <- 1 / da22
  }

  # lower-left block
  A21.inv <- -A22.inv %*% A21 %*% A11.inv

  # upper-left block remains zero
  A12.inv <- A12

  # construct B.inv
  B.inv <- rbind(
    cbind(A11.inv, A12.inv),
    cbind(A21.inv, A22.inv)
  )


  #  weight matrix (correlation metric)
  WLS.W <- B.inv %*% INNER %*% t(B.inv)

  # COV matrix?
  if (any("numeric" %in% ov.types)) {
    COV <- lav_cor2cov(R = COR, sds = sqrt(unlist(VAR)))

    # construct H matrix to apply delta rule (for the tranformation
    # of rho_ij to cov_ij)
    H11 <- diag(NROW(A11))
    H12 <- matrix(0, NROW(A11), NCOL(A22))
    # H22 and H21 already filled in
    H <- rbind(
      cbind(H11, H12),
      cbind(H21, H22)
    )

    WLS.W <- H %*% WLS.W %*% t(H)
  } else {
    COV <- COR
    H <- diag(NCOL(WLS.W))
  }

  # reverse sign numeric TH (because we provide -mu in WLS.obs)
  # (WOW, it took me a LOOONGGG time to realize this!)
  # YR 16 July 2012

  # NOTE: prior to 0.5-17, we used num.idx (instead of NUM.idx)
  # which is WRONG if we have more than one threshold per variable
  # (thanks to Sacha Epskamp for spotting this!)
  if (length(num.idx) > 0L) {
    NUM.idx <- which(unlist(TH.IDX) == 0L)
    WLS.W[NUM.idx, ] <- -WLS.W[NUM.idx, ]
    WLS.W[, NUM.idx] <- -WLS.W[, NUM.idx]
  }


  out <- list(
    TH = TH, SLOPES = SLOPES, VAR = VAR, COR = COR, COV = COV,
    SC = SC, TH.NOX = TH.NOX, TH.NAMES = TH.NAMES, TH.IDX = TH.IDX,
    INNER = INNER, A11 = A11, A12 = A12, A21 = A21, A22 = A22,
    WLS.W = WLS.W, H = H,
    zero.cell.tables = empty.cell.tables
  )
  out
}

lav_pml_plrt <- function(lavobject = NULL, lavmodel = NULL, lavdata = NULL,
                         lavsamplestats = NULL, lavpartable = NULL,
                         lavoptions = NULL, x = NULL, VCOV = NULL,
                         lavcache = NULL) {
  lavpta <- NULL
  if (!is.null(lavobject)) {
    lavmodel <- lavobject@Model
    lavdata <- lavobject@Data
    lavoptions <- lavobject@Options
    lavsamplestats <- lavobject@SampleStats
    lavcache <- lavobject@Cache
    lavpartable <- lav_partable_set_cache(lavobject@ParTable, lavobject@pta)
    lavpta <- lavobject@pta
  }
  if (is.null(lavpta)) {
    lavpta <- lav_partable_attributes(lavpartable)
    lavpartable <- lav_partable_set_cache(lavpartable, lavpta)
  }

  if (is.null(x)) {
    # compute 'fx' = objective function value
    # (NOTE: since 0.5-18, NOT divided by N!!)
    fx <- lav_model_objective(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats,
      lavdata = lavdata,
      lavcache = lavcache
    )
    H0.fx <- as.numeric(fx)
    H0.fx.group <- attr(fx, "fx.group")
  } else {
    H0.fx <- attr(attr(x, "fx"), "fx.pml")
    H0.fx.group <- attr(attr(x, "fx"), "fx.group")
  }

  # fit a saturated model 'fittedSat'
  ModelSat <- lav_partable_unrestricted(
    lavobject = NULL,
    lavdata = lavdata,
    lavoptions = lavoptions,
    lavpta = lavpta,
    lavsamplestats = lavsamplestats
  )

  # FIXME: se="none", test="none"??
  Options <- lavoptions
  Options$se <- "none"
  Options$test <- "none"
  Options$baseline <- FALSE
  Options$h1 <- FALSE
  fittedSat <- lavaan(ModelSat,
    slotOptions = Options, verbose = FALSE,
    slotSampleStats = lavsamplestats,
    slotData = lavdata, slotCache = lavcache
  )
  fx <- lav_model_objective(
    lavmodel = fittedSat@Model,
    lavsamplestats = fittedSat@SampleStats,
    lavdata = fittedSat@Data,
    lavcache = fittedSat@Cache
  )
  SAT.fx <- as.numeric(fx)
  SAT.fx.group <- attr(fx, "fx.group")

  # we also need a `saturated model', but where the moments are based
  # on the model-implied sample statistics under H0
  ModelSat2 <-
    lav_partable_unrestricted(
      lavobject = NULL,
      lavdata = lavdata,
      lavoptions = lavoptions,
      lavsamplestats = NULL,
      sample.cov = lav_model_sigma(lavmodel),
      sample.mean = lav_model_mu(lavmodel),
      sample.th = lav_model_th(lavmodel),
      sample.th.idx = lavsamplestats@th.idx
    )

  Options2 <- Options
  Options2$optim.method <- "none"
  Options2$optim.force.converged <- TRUE
  Options2$check.start <- FALSE
  Options2$check.gradient <- FALSE
  Options2$check.post <- FALSE
  Options2$check.vcov <- FALSE
  fittedSat2 <- lavaan(ModelSat2,
    slotOptions = Options2, verbose = FALSE,
    slotSampleStats = lavsamplestats,
    slotData = lavdata, slotCache = lavcache
  )

  # the code below was contributed by Myrsini Katsikatsou (Jan 2015)

  # for now, only a single group is supported:
  # g = 1L


  ########################### The code for PLRT for overall goodness of fit

  # First define the number of non-redundant elements of the (fitted)
  # covariance/correlation matrix of the underlying variables.
  # nvar <- lavmodel@nvar[[g]]
  # dSat <- nvar*(nvar-1)/2
  # if(length(lavmodel@num.idx[[g]]) > 0L) {
  #    dSat <- dSat + length(lavmodel@num.idx[[g]])
  # }

  # select `free' parameters (excluding thresholds) from fittedSat2 model
  PT.Sat2 <- fittedSat2@ParTable
  dSat.idx <- PT.Sat2$free[PT.Sat2$free > 0L & PT.Sat2$op != "|"]
                                                        # remove thresholds

  # Secondly, we need to specify the indices of the rows/columns of vcov(),
  # hessian, and variability matrix that refer to all SEM parameters
  # except thresholds.
  PT <- lavpartable
  index.par <- PT$free[PT$free > 0L & PT$op != "|"]

  # Thirdly, specify the sample size.
  # nsize <- lavdata@nobs[[g]]
  nsize <- lavsamplestats@ntotal

  # Now we can proceed to the computation of the quantities needed for PLRT.
  # Briefly, to say that PLRT is equal to the difference of two quadratic forms.
  # To compute the first and second moment adjusted PLRT we should compute
  # the asymptotic mean and variance of each quadratic quantity as well as
  # their asymptotic covariance.

  ##### Section 1. Compute the asymptotic mean and variance
  #####            of the first quadratic quantity
  # Below I assume that lavobject is the output of lavaan function. I guess
  # vcov(lavobject) can be substituted by VCOV object insed lavaan function
  # defined at lines 703 -708. But what is the object inside lavaan function
  # for getHessian(lavobject)?
  if (is.null(VCOV)) {
    lavoptions$se <- "robust.huber.white"
    VCOV <- lav_model_vcov(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats,
      lavoptions = lavoptions,
      lavdata = lavdata,
      lavpartable = lavpartable,
      lavcache = lavcache
    )
  }
  InvG_to_psipsi_attheta0 <- (lavsamplestats@ntotal * VCOV)[index.par,
                             index.par, drop = FALSE] # G^psipsi(theta0)
  # below the lavaan function getHessian is used
  # Hattheta0 <- (-1) * H0.Hessian
  # Hattheta0 <- H0.Hessian
  # InvHattheta0 <- solve(Hattheta0)
  InvHattheta0 <- attr(VCOV, "E.inv")
  InvH_to_psipsi_attheta0 <- InvHattheta0[index.par, index.par, drop = FALSE]
                                                           # H^psipsi(theta0)
  if (lavmodel@eq.constraints) {
    IN <- InvH_to_psipsi_attheta0
    IN.npar <- ncol(IN)

    # create `bordered' matrix
    if (nrow(lavmodel@con.jac) > 0L) {
      H <- lavmodel@con.jac[, index.par, drop = FALSE]
      inactive.idx <- attr(H, "inactive.idx")
      lambda <- lavmodel@con.lambda # lagrangean coefs
      if (length(inactive.idx) > 0L) {
        H <- H[-inactive.idx, , drop = FALSE]
        lambda <- lambda[-inactive.idx]
      }
      if (nrow(H) > 0L) {
        H0 <- matrix(0, nrow(H), nrow(H))
        H10 <- matrix(0, ncol(IN), nrow(H))
        DL <- 2 * diag(lambda, nrow(H), nrow(H))
        # FIXME: better include inactive + slacks??
        E3 <- rbind(
          cbind(IN, H10, t(H)),
          cbind(t(H10), DL, H0),
          cbind(H, H0, H0)
        )
        Inv_of_InvH_to_psipsi_attheta0 <-
          MASS::ginv(IN)[1:IN.npar, 1:IN.npar, drop = FALSE]
      } else {
        Inv_of_InvH_to_psipsi_attheta0 <- solve(IN)
      }
    }
  } else {
    # YR 26 June 2018: check for empty index.par (eg independence model)
    if (length(index.par) > 0L) {
      Inv_of_InvH_to_psipsi_attheta0 <-
        solve(InvH_to_psipsi_attheta0) # [H^psipsi(theta0)]^(-1)
    } else {
      Inv_of_InvH_to_psipsi_attheta0 <- matrix(0, 0, 0)
    }
  }

  H0tmp_prod1 <- Inv_of_InvH_to_psipsi_attheta0 %*% InvG_to_psipsi_attheta0
  H0tmp_prod2 <- H0tmp_prod1 %*% H0tmp_prod1
  E_tww <- sum(diag(H0tmp_prod1)) # expected mean of first quadratic quantity
  var_tww <- 2 * sum(diag(H0tmp_prod2)) # variance of first quadratic quantity

  ##### Section 2: Compute the asymptotic mean and variance
  #####            of the second quadratic quantity.
  # Now we need to evaluate the fitted (polychoric) correlation/ covariance
  # matrix using the estimates of SEM parameters derived under the fitted model
  # which is the model of the null hypothesis. We also need to compute the
  # vcov matrix of these estimates (estimates of polychoric correlations)
  # as well as the related hessian and variability matrix.
  tmp.options <- fittedSat2@Options
  tmp.options$se <- lavoptions$se
  VCOV.Sat2 <- lav_model_vcov(
    lavmodel = fittedSat2@Model,
    lavsamplestats = fittedSat2@SampleStats,
    lavoptions = tmp.options,
    lavdata = fittedSat2@Data,
    lavpartable = fittedSat2@ParTable,
    lavcache = fittedSat2@Cache,
    use.ginv = TRUE
  )
  InvG_to_sigmasigma_attheta0 <- lavsamplestats@ntotal * VCOV.Sat2[dSat.idx,
                                dSat.idx, drop = FALSE] # G^sigmasigma(theta0)
  # Hattheta0 <- (-1)* getHessian(fittedSat2)
  # Hattheta0 <- getHessian(fittedSat2)
  # InvHattheta0 <- solve(Hattheta0)
  InvHattheta0 <- attr(VCOV.Sat2, "E.inv")
  InvH_to_sigmasigma_attheta0 <- InvHattheta0[dSat.idx, dSat.idx, drop = FALSE]
                                                          # H^sigmasigma(theta0)
  # Inv_of_InvH_to_sigmasigma_attheta0 <- solve(InvH_to_sigmasigma_attheta0)
  #                                                 #[H^sigmasigma(theta0)]^(-1)
  Inv_of_InvH_to_sigmasigma_attheta0 <- MASS::ginv(InvH_to_sigmasigma_attheta0,
    tol = .Machine$double.eps^(3 / 4)
  )
  H1tmp_prod1 <- Inv_of_InvH_to_sigmasigma_attheta0 %*%
                            InvG_to_sigmasigma_attheta0
  H1tmp_prod2 <- H1tmp_prod1 %*% H1tmp_prod1
  E_tzz <- sum(diag(H1tmp_prod1)) # expected mean of the second
                                  # quadratic quantity
  var_tzz <- 2 * sum(diag(H1tmp_prod2)) # variance of the second
                                        # quadratic quantity

  ##### Section 3: Compute the asymptotic covariance of
  #####            the two quadratic quantities

  drhodpsi_MAT <- vector("list", length = lavsamplestats@ngroups)
  group.values <- lav_partable_group_values(fittedSat2@ParTable)
  for (g in 1:lavsamplestats@ngroups) {
    # delta.g <- lav_model_delta(lavmodel)[[g]] # [[1]] to be substituted by g?
    # The above gives the derivatives of thresholds and polychoric correlations
    # with respect to SEM param (including thresholds) evaluated under H0.
    # From deltamat we need to exclude the rows and columns referring
    # to thresholds.
    # For this:

    # order of the rows: first the thresholds, then the correlations
    # we need to map the rows of delta.g to the rows/cols of H_at_vartheta0
    # of H1

    PT <- fittedSat2@ParTable
    PT$label <- lav_partable_labels(PT)
    free.idx <- which(PT$free > 0 & PT$op != "|" & PT$group == group.values[g])
    PARLABEL <- PT$label[free.idx]

    # for now, we can assume that lav_model_delta will always return
    # the thresholds first, then the correlations
    #
    # later, we should add a (working) add.labels = TRUE option to
    # lav_model_delta
    # th.names <- lavobject@pta$vnames$th[[g]]
    # ov.names <- lavobject@pta$vnames$ov[[g]]
    # th.names <- lav_object_vnames(lavpartable, "th")
    # ov.names <- lav_object_vnames(lavpartable, "ov.nox")
    # ov.names.x <- lav_object_vnames(lavpartable, "ov.x")
    # tmp <- utils::combn(ov.names, 2)
    # cor.names <- paste(tmp[1,], "~~", tmp[2,], sep = "")

    # added by YR - 22 Okt 2017 #####################################
    # ov.names.x <- lav_object_vnames(lavpartable, "ov.x")
    # if(length(ov.names.x)) {
    #    slope.names <- apply(expand.grid(ov.names, ov.names.x), 1L,
    #                             paste, collapse = "~")
    # } else {
    #    slope.names <- character(0L)
    # }
    #################################################################

    # NAMES <- c(th.names, slope.names, cor.names)

    # added by YR - 26 April 2018, for 0.6-1
    # we now can get 'labelled' delta rownames
    delta.g <- lav_object_inspect_delta_internal(
      lavmodel = lavmodel,
      lavdata = lavdata, lavpartable = lavpartable,
      add.labels = TRUE, add.class = FALSE,
      drop.list.single.group = FALSE
    )[[g]]
    NAMES <- rownames(delta.g)
    if (g > 1L) {
      NAMES <- paste(NAMES, ".g", g, sep = "")
    }

    par.idx <- match(PARLABEL, NAMES)
    if (any(is.na(par.idx))) {
      lav_msg_warn(gettextf(
        "mismatch between DELTA labels and PAR labels!
        PARLABEL: %1$s, DELTA LABELS: %2$s", lav_msg_view(PARLABEL),
         lav_msg_view(NAMES)))
    }

    drhodpsi_MAT[[g]] <- delta.g[par.idx, index.par, drop = FALSE]
  }
  drhodpsi_mat <- do.call(rbind, drhodpsi_MAT)

  tmp_prod <- t(drhodpsi_mat) %*% Inv_of_InvH_to_sigmasigma_attheta0 %*%
    drhodpsi_mat %*% InvG_to_psipsi_attheta0 %*% H0tmp_prod1
  cov_tzztww <- 2 * sum(diag(tmp_prod))

  ##### Section 4: compute the adjusted PLRT and its p-value
  # PLRTH0Sat <- 2*nsize*(lavfit@fx - fittedSat@Fit@fx)
  PLRTH0Sat <- 2 * (H0.fx - SAT.fx)
  PLRTH0Sat.group <- 2 * (H0.fx.group - SAT.fx.group)
  asym_mean_PLRTH0Sat <- E_tzz - E_tww
  # catch zero value for asym_mean_PLRTH0Sat
  if (asym_mean_PLRTH0Sat == 0) {
    asym_var_PLRTH0Sat <- 0
    scaling.factor <- as.numeric(NA)
    FSA_PLRT_SEM <- as.numeric(NA)
    adjusted_df <- as.integer(NA)
    pvalue <- as.numeric(NA)
  } else if (any(is.na(c(var_tzz, var_tww, cov_tzztww)))) {
    asym_var_PLRTH0Sat <- as.numeric(NA)
    scaling.factor <- as.numeric(NA)
    FSA_PLRT_SEM <- as.numeric(NA)
    adjusted_df <- as.integer(NA)
    pvalue <- as.numeric(NA)
  } else {
    asym_var_PLRTH0Sat <- var_tzz + var_tww - 2 * cov_tzztww
    scaling.factor <- (asym_mean_PLRTH0Sat / (asym_var_PLRTH0Sat / 2))
    FSA_PLRT_SEM <- (asym_mean_PLRTH0Sat / (asym_var_PLRTH0Sat / 2)) * PLRTH0Sat
    adjusted_df <- (asym_mean_PLRTH0Sat * asym_mean_PLRTH0Sat) /
      (asym_var_PLRTH0Sat / 2)
    # In some very few cases (simulations show very few cases in small
    # sample sizes) the adjusted_df is a negative number, we should then
    # print a warning like: "The adjusted df is computed to be a negative number
    # and for this the first and second moment adjusted PLRT is not computed."
    if (scaling.factor > 0) {
      pvalue <- 1 - pchisq(FSA_PLRT_SEM, df = adjusted_df)
    } else {
      pvalue <- as.numeric(NA)
    }
  }

  list(
    PLRTH0Sat = PLRTH0Sat, PLRTH0Sat.group = PLRTH0Sat.group,
    stat = FSA_PLRT_SEM, df = adjusted_df, p.value = pvalue,
    scaling.factor = scaling.factor
  )
}
############################################################################


lav_pml_object_aic_bic <- function(lavobject) {
  ########################## The code for PL version fo AIC and BIC
  # The following should be done because it is not the pl log-likelihood
  # that is maximized but a fit function that should be minimized. So, we
  # should find the value of log-PL at the estimated parameters through the
  # value of the fitted function.
  # The following may need to be updated if we change the fit function
  # so that it is correct for the case of missing values as well.

  logPL <- lavobject@optim$logl
  nsize <- lavobject@SampleStats@ntotal

  # inverted observed unit information
  H.inv <- lavTech(lavobject, "inverted.information.observed")

  # first order unit information
  J <- lavTech(lavobject, "information.first.order")

  # trace (J %*% H.inv) = sum (J * t(H.inv))
  dimTheta <- sum(J * H.inv)


  # computations of PL versions of AIC and BIC
  PL_AIC <- (-2) * logPL + 2 * dimTheta
  PL_BIC <- (-2) * logPL + dimTheta * log(nsize)

  list(logPL = logPL, PL_AIC = PL_AIC, PL_BIC = PL_BIC)
}

# update lavdata object
# - new dataset (lav_data_update)
# - only subset of data (lav_data_update_subset) (for sam())

# YR - 18 Jan 2021 (so we don't need to export lav_data_*_patterns functions)
#    - 28 May 2023 lav_data_update_subset()

# update lavdata object with new dataset
# - assuming everything else stays the same
# - optionally, also provide boot.idx (per group) to adapt internal slots
lav_data_update <- function(lavdata = NULL, newX = NULL, BOOT.idx = NULL,
                            lavoptions = NULL) {
  stopifnot(length(newX) == lavdata@ngroups)
  stopifnot(!is.null(lavoptions))
  newdata <- lavdata

  # replace data 'X' slot for each group
  for (g in 1:lavdata@ngroups) {
    # replace raw data
    newdata@X[[g]] <- newX[[g]]

    # Mp + nobs
    if (lavoptions$missing != "listwise") {
      newdata@Mp[[g]] <- lav_data_missing_patterns(newX[[g]],
        sort.freq = FALSE, coverage = TRUE
      )
      newdata@nobs[[g]] <-
        (nrow(newdata@X[[g]]) - length(newdata@Mp[[g]]$empty.idx))
    }

    # Rp
    if (length(lavdata@ov.names.x[[g]]) == 0L &&
      all(lavdata@ov.names[[g]] %in%
        lavdata@ov$name[lavdata@ov$type == "ordered"])) {
      newdata@Rp[[g]] <- lav_data_resp_patterns(newX[[g]])
    }

    # Lp
    if (lavdata@nlevels > 1L) {
      # CHECKME!
      # extract cluster variable(s), for this group
      clus <- matrix(0, nrow(newX[[g]]), lavdata@nlevels - 1L)
      for (l in 2:lavdata@nlevels) {
        clus[, (l - 1L)] <- lavdata@Lp[[g]]$cluster.idx[[l]]
      }
      newdata@Lp[[g]] <- lav_data_cluster_patterns(
        Y = newX[[g]],
        clus = clus,
        cluster = lavdata@cluster,
        ov.names = lavdata@ov.names[[g]],
        ov.names.l = lavdata@ov.names.l[[g]]
      )
    }
  }

  # if boot.idx if provided, also adapt eXo and WT
  if (!is.null(BOOT.idx)) {
    boot.idx <- BOOT.idx[[g]]

    # eXo
    if (!is.null(lavdata@eXo[[g]])) {
      newdata@eXo[[g]] <- lavdata@eXo[[g]][boot.idx, , drop = FALSE]
    }

    # sampling weights
    if (!is.null(lavdata@weights[[g]])) {
      newdata@weights[[g]] <- lavdata@weights[[g]][boot.idx]
    }
  } # g

  # return update data object
  newdata
}

# update lavdata, keeping only a subset of the observed variables
# (assuming everything else stays the same)
lav_data_update_subset <- function(lavdata = NULL, ov.names = NULL) {
  stopifnot(length(ov.names) == length(lavdata@ov.names))
  newdata <- lavdata

  # replace ov.names
  newdata@ov.names <- ov.names

  # ordered?
  if (length(lavdata@ordered) > 0L) {
    newdata@ordered <- lavdata@ordered[lavdata@ordered %in% ov.names]
  }

  # replace/update slots for each group
  for (g in 1:lavdata@ngroups) {
    # sanity check:
    if (all(lavdata@ov.names[[g]] %in% ov.names[[g]])) {
      # nothing to do
      next
    }

    # replace ov.names.x
    if (length(lavdata@ov.names.x[[g]]) > 0L) {
      newdata@ov.names.x[[g]] <- lavdata@ov.names.x[[g]][lavdata@ov.names.x[[g]] %in% ov.names[[g]]]
    }

    # replace ov.names.l
    if (newdata@nlevels > 1L) {
      for (l in 1:newdata@nlevels) {
        newdata@ov.names.l[[g]][[l]] <- lavdata@ov.names.l[[g]][[l]][lavdata@ov.names.l[[g]][[l]] %in% ov.names[[g]]]
      }
    }

    # ov table
    keep.idx <- which(lavdata@ov$name %in% unlist(ov.names))
    newdata@ov <- lapply(lavdata@ov, "[", keep.idx)

    # replace raw data
    newdata@X[[g]] <- lavdata@X[[g]][, lavdata@ov.names[[g]] %in% ov.names[[g]], drop = FALSE]

    # eXo
    if (length(newdata@ov.names.x[[g]]) == 0L) {
      newdata@eXo[g] <- list(NULL)
    } else {
      newdata@eXo[[g]] <- lavdata@eXo[[g]][, lavdata@ov.names.x[[g]] %in% ov.names[[g]], drop = FALSE]
    }

    # Mp + nobs
    if (lavdata@missing != "listwise") {
      newdata@Mp[[g]] <- lav_data_missing_patterns(newdata@X[[g]],
        sort.freq = FALSE, coverage = TRUE
      )
      newdata@nobs[[g]] <-
        (nrow(newdata@X[[g]]) - length(newdata@Mp[[g]]$empty.idx))
    }

    # Rp
    if (length(newdata@ordered) == 0L) {
      # nothing to do
    } else if (length(newdata@ov.names.x[[g]]) == 0L &&
      all(newdata@ov.names[[g]] %in%
        newdata@ov$name[newdata@ov$type == "ordered"])) {
      newdata@Rp[[g]] <- lav_data_resp_patterns(newdata@X[[g]])
    }

    # Lp
    if (length(newdata@cluster) > 0L) {
      # extract cluster variable(s), for this group
      clus <- matrix(0, nrow(newdata@X[[g]]), lavdata@nlevels - 1L)
      for (l in 2:lavdata@nlevels) {
        clus[, (l - 1L)] <- lavdata@Lp[[g]]$cluster.idx[[l]]
      }
      if (newdata@nlevels > 1L) {
        multilevel <- TRUE
      } else {
        multilevel <- FALSE
      }
      OV.NAMES <- unique(c(ov.names[[g]], newdata@ov.names.x[[g]]))
      newdata@Lp[[g]] <- lav_data_cluster_patterns(
        Y = newdata@X[[g]],
        clus = clus,
        cluster = newdata@cluster,
        multilevel = multilevel,
        ov.names = OV.NAMES,
        ov.names.x = newdata@ov.names.x[[g]],
        ov.names.l = newdata@ov.names.l[[g]]
      )
    }
  } # g

  # return update data object
  newdata
}

# This code was contributed by Myrsini Katsikatsou (LSE) -- September 2016
#
# lav_pml_bivprob_unicondprob()
# lav_pml_object_uni_pairwise_prob()
# lav_pml_th_rho_generalised()
# pairwiseExpProbVec_GivenObs_UncMod()

lav_pml_bivprob_unicondprob <- function(bivProb, nvar,
                                                 idx.pairs,
                                                 idx.Y1,
                                                 idx.Gy2,
                                                 idx.cat.y1.split,
                                                 idx.cat.y2.split) {
  bivProb.split <- split(bivProb, idx.pairs)
  lngth <- 2 * length(bivProb)
  idx.vec.el <- 1:lngth
  ProbY1Gy2 <- rep(NA, lngth)
  no.pairs <- nvar * (nvar - 1) / 2
  idx2.pairs <- combn(nvar, 2)

  for (k in 1:no.pairs) {
    y2Sums <- tapply(bivProb.split[[k]], idx.cat.y2.split[[k]], sum)
    y2Sums.mult <- y2Sums[idx.cat.y2.split[[k]]]
    Y1Gy2 <- bivProb.split[[k]] / y2Sums.mult
    tmp.idx.vec.el <- idx.vec.el[(idx.Y1 == idx2.pairs[1, k]) &
      (idx.Gy2 == idx2.pairs[2, k])]
    ProbY1Gy2[tmp.idx.vec.el] <- Y1Gy2
  }

  for (k in 1:no.pairs) {
    y1Sums <- tapply(bivProb.split[[k]], idx.cat.y1.split[[k]], sum)
    y1Sums.mult <- y1Sums[idx.cat.y1.split[[k]]]
    Y2Gy1 <- bivProb.split[[k]] / y1Sums.mult
    reordered_Y2Gy1 <- Y2Gy1[order(idx.cat.y1.split[[k]])]
    tmp.idx.vec.el <- idx.vec.el[(idx.Y1 == idx2.pairs[2, k]) &
      (idx.Gy2 == idx2.pairs[1, k])]
    ProbY1Gy2[tmp.idx.vec.el] <- reordered_Y2Gy1
  }

  ProbY1Gy2
}

# The input of the function is a lavobject, which, in turn, is the output of the
# sem function having specified estimator="PML", missing="available.cases"

# The output of the function is a list of two lists: the pairwiseProbGivObs list and
# the univariateProbGivObs list. Each of the two lists consists of G matrices where G
# is the number of groups in a multigroup analysis. If G=1 each of the lists
# contains only one matrix that can be called as pairwiseProbGivObs[[1]], and
# univariateProbGivObs[[1]].

# Each of the matrices in the pairwiseProbGivObs list is of dimension: nrow=sample size,
# ncol=sum of the number of response categories for all pairs of variables
# (i.e. the length of the vector pxixj.ab where i<j=1,...,p, a=1,...,Ci, b=1,...,Cj;
# a which is the index for the response category for yi variable runs the fastest,
# then b which is the index for the response category for yj variable,
# then j, and last i.)
# The cells in a matrix of the pairwiseProbGivObs list have the value 0 except for
# those cells that correspond to the pairs of variables where both variables
# are missing. Those cells have the value of the bivariate conditional probability
# for the given pair for all their response categories. The bivariate
# probabilities are computed as follows:
# the information in the observed variables is summarised in a factor score
# for each individual and the bivariate probability given the estimated factor
# scores is computed.


# Each of the matrices in the univariateProbGivObs list is of dimension:
# nrow=sample size, ncol=sum of the number of response categories for all
# variables. The columns are indexed with i and a, where i=1,...,p, and
# a=1,...,Ci, the response categories for yi variable; a runs faster than i.
# The cells in a matrix of the univariateProbGivObs list have the value 0 except for
# those cells that correspond to variables with missing values.
# Those cells have the value of the univariate conditional probability for the
# given variable for all its response categories. The univariate conditional
# probabilities are computed as follows:
# given that the bivariate conditional probabilities have been computed we sum over
# the response categories of each variable at a time (i.e. we compute the marginals).

# Version 3 - first compute univariate and then bivariate probabilities

lav_pml_object_uni_pairwise_prob <- function(lavobject) {
  # compute yhat where yaht=nu + Lamda*eta + K*x where the parameter estimates are
  # used and the factor scores for eta
  # Below yhat is a list if lavobject@Data@ngroups >1, it is a list of G matrices
  # where G the number of groups and the matrices are fo dimension
  # nrow=sample size and ncol=number of items.
  # If lavobject@Data@ngroups=1 then yhat is a matrix.
  yhat <- lavPredict(object = lavobject, type = "yhat")

  # compute bivariate probabilities
  ngroups <- lavobject@Data@ngroups
  univariateProb <- vector("list", length = ngroups)
  pairwiseProb <- vector("list", length = ngroups)
  # save the indices of the Theta matrices for the groups stored in GLIST
  idx.ThetaMat <- which(names(lavobject@Model@GLIST) == "theta")

  for (g in seq_len(ngroups)) { # g<-1

    if (ngroups > 1L) {
      yhat_group <- yhat[[g]]
    } else {
      yhat_group <- yhat
    }

    nsize <- lavobject@Data@nobs[[g]]
    nvar <- lavobject@Model@nvar[[g]]
    Data <- lavobject@Data@X[[g]]
    TH <- lavobject@Fit@TH[[g]]
    th.idx <- lavobject@Model@th.idx[[g]]
    Theta <- lavobject@Model@GLIST[idx.ThetaMat[g]]$theta
    error.stddev <- diag(Theta)^0.5

    # for the computation of the univariate probabilities
    nlev <- lavobject@Data@ov$nlev
    idx.uniy <- rep(1:nvar, times = nlev)

    # indices vectors for the computation of bivariate probabilities
    idx.pairs.yiyj <- combn(1:nvar, 2)
    no_biv_resp_cat_yiyj <- sapply(1:ncol(idx.pairs.yiyj), function(x) {
      prod(nlev[idx.pairs.yiyj[, x]])
    })
    idx.y1 <- unlist(
      mapply(rep, idx.pairs.yiyj[1, ], each = no_biv_resp_cat_yiyj)
    )
    idx.y2 <- unlist(
      mapply(rep, idx.pairs.yiyj[2, ], each = no_biv_resp_cat_yiyj)
    )


    univariateProb[[g]] <- matrix(0, nrow = nsize, ncol = sum(nlev))
    pairwiseProb[[g]] <- matrix(0,
      nrow = nsize,
      ncol = length(lavobject@Cache[[g]]$bifreq)
    )

    idx.MissVar.casewise <- apply(Data, 1, function(x) {
      which(is.na(x))
    })

    for (i in 1:nsize) {
      idx.MissVar <- idx.MissVar.casewise[[i]]
      noMissVar <- length(idx.MissVar)

      if (noMissVar > 0L) {
        # compute the univariate probabilities
        TH.list <- split(TH, th.idx)
        tmp.TH <- TH.list[idx.MissVar]
        tmp.lowerTH <- unlist(lapply(tmp.TH, function(x) {
          c(-Inf, x)
        }))
        tmp.upperTH <- unlist(lapply(tmp.TH, function(x) {
          c(x, Inf)
        }))

        idx.items <- rep(c(1:noMissVar), times = nlev[idx.MissVar])
        tmp.mean <- yhat_group[i, idx.MissVar]
        tmp.mean.extended <- tmp.mean[idx.items]
        tmp.stddev <- error.stddev[idx.MissVar]
        tmp.stddev.extended <- tmp.stddev[idx.items]

        tmp.uniProb <- pnorm((tmp.upperTH - tmp.mean.extended) /
          tmp.stddev.extended) -
          pnorm((tmp.lowerTH - tmp.mean.extended) /
            tmp.stddev.extended)
        idx.columnsUni <- which(idx.uniy %in% idx.MissVar)
        univariateProb[[g]][i, idx.columnsUni] <- tmp.uniProb

        # compute the bivariate probabilities
        if (noMissVar > 1L) {
          idx.pairsMiss <- combn(idx.MissVar, 2)
          no.pairs <- ncol(idx.pairsMiss)
          idx.pairsV2 <- combn(noMissVar, 2)
          idx.columns <- unlist(lapply(1:no.pairs, function(x) {
            which((idx.y1 == idx.pairsMiss[1, x]) &
              (idx.y2 == idx.pairsMiss[2, x]))
          }))

          if (all(Theta[t(idx.pairsMiss)] == 0)) { # items independence given eta
            tmp.uniProb.list <- split(tmp.uniProb, idx.items)
            pairwiseProb[[g]][i, idx.columns] <-
              unlist(lapply(1:no.pairs, function(x) {
                c(outer(
                  tmp.uniProb.list[[idx.pairsV2[1, x]]],
                  tmp.uniProb.list[[idx.pairsV2[2, x]]]
                ))
              }))
          } else { # when correlation between measurement errors

            tmp.th.idx <- th.idx[th.idx %in% idx.MissVar]
            # recode so that it is always 1,1,..,1, 2,...,2, etc.
            tmp.th.idx.recoded <- rep(c(1:noMissVar), times = table(tmp.th.idx))
            tmp.TH <- TH[th.idx %in% idx.MissVar]

            tmp.ind.vec <- lav_pml_longvec_ind(
              no.x = noMissVar,
              all.thres = tmp.TH,
              index.var.of.thres = tmp.th.idx.recoded
            )

            tmp.th.rho.vec <- lav_pml_th_rho_generalised(
              no.x = noMissVar,
              TH = tmp.TH,
              th.idx = tmp.th.idx.recoded,
              cov.xixj = Theta[t(idx.pairsMiss)],
              mean.x = yhat_group[i, idx.MissVar],
              stddev.x = error.stddev[idx.MissVar]
            )

            tmp.bivProb <- lav_pml_expprob_vec(
              ind.vec = tmp.ind.vec,
              th.rho.vec = tmp.th.rho.vec
            )

            pairwiseProb[[g]][i, idx.columns] <- tmp.bivProb
          } # end of else of if( all( Theta[t(idx.pairsMiss)]==0 ) )
          # which checks item local independence
        } # end of if( noMissVar>1L )

        # cat(i,  "\n")
      } # end of if(noMissVar>0L)
    } # end of for(i in 1:nsize)
  } # end of for(g in seq_len(lavobject@Data@ngroups))

  list(
    univariateProbGivObs = univariateProb,
    pairwiseProbGivObs = pairwiseProb
  )
} # end of the function lav_pml_object_uni_pairwise_prob

##################################################################



# lav_pml_th_rho_generalised function is defined as follows
lav_pml_th_rho_generalised <- function(no.x, TH, th.idx,
                                      cov.xixj, mean.x, stddev.x) {
  all.std.thres <- (TH - mean.x[th.idx]) / stddev.x[th.idx]
  id.pairs <- utils::combn(no.x, 2)
  cor.xixj <- cov.xixj / (stddev.x[id.pairs[1, ]] * stddev.x[id.pairs[2, ]])

  lav_pml_longvec_th_rho(
    no.x = no.x,
    all.thres = all.std.thres,
    index.var.of.thres = th.idx,
    rho.xixj = cor.xixj
  )
}

# lav_pml_th_rho_generalised is a generalisation  of the function
#  lavaan:::lav_pml_longvec_th_rho . The latter assumes that all y* follow standard
#  normal so the thresholds are automatically the standardised ones.
# lav_pml_th_rho_generalised does not assume that, each of y*'s can follow
# a normal distribution with mean mu and standard deviation sigma.
# lav_pml_th_rho_generalised has the following input arguments:
# no.x (same as in lavaan:::lav_pml_longvec_th_rho),
# TH (similar to the TH in lavaan:::lav_pml_longvec_th_rho but here they are the unstandardised thresholds, i.e. of the normal distribution with mean mu and standard deviation sigma)
# th.idx (same as index.var.of.thres in lavaan:::lav_pml_longvec_th_rho)
# cov.xixj which are the polychoric covariances of the pairs of underlying variables provided in a similar fashion as rho.xixj in lavaan:::lav_pml_longvec_th_rho)
# mean.x  is a vector including the means of y*'s provided in the order mean.x1, mean.x2, ...., mean.xp
# stddev.x  is a vector including the standard deviations of y*'s provided in the order stddev.x1, stddev.x2, ...., stddev.xp

# The output of the new function is similar to that of lavaan:::lav_pml_longvec_th_rho#############################################



# lavobject is the output of lavaan function where either the unconstrained
# or a hypothesized model has been fitted
lav_pml_object_uni_pairwise_unconstr<- function(lavobject) {
  ngroups <- lavobject@Data@ngroups
  TH <- lavobject@implied$th # these are the standardized thresholds
  # mean and variance of y* have been taken into account
  TH.IDX <- lavobject@SampleStats@th.idx
  Sigma.hat <- lavobject@implied$cov

  univariateProb <- vector("list", length = ngroups)
  pairwiseProb <- vector("list", length = ngroups)

  for (g in 1:ngroups) {
    Sigma.hat.g <- Sigma.hat[[g]]
    # is Sigma.hat always a correlation matrix?
    Cor.hat.g <- cov2cor(Sigma.hat.g)
    cors <- Cor.hat.g[lower.tri(Cor.hat.g)]
    if (any(abs(cors) > 1)) {
      lav_msg_warn(gettext(
      "some model-implied correlations are larger than 1.0"))
    }
    nvar <- nrow(Sigma.hat.g)
    MEAN <- rep(0, nvar)
    TH.g <- TH[[g]]
    th.idx.g <- TH.IDX[[g]]

    nlev <- lavobject@Data@ov$nlev

    # create index vector to keep track which variable each column of
    # univariateProb matrix refers to
    idx.uniy <- rep(1:nvar, times = nlev)

    # create index vector to keep track which variables each column of
    # pairwiseProb matrix refers to
    idx.pairs.yiyj <- combn(1:nvar, 2)
    no_biv_resp_cat_yiyj <- sapply(1:ncol(idx.pairs.yiyj), function(x) {
      prod(nlev[idx.pairs.yiyj[, x]])
    })
    idx.y1 <- unlist(
      mapply(rep, idx.pairs.yiyj[1, ], each = no_biv_resp_cat_yiyj)
    )
    idx.y2 <- unlist(
      mapply(rep, idx.pairs.yiyj[2, ], each = no_biv_resp_cat_yiyj)
    )

    Data <- lavobject@Data@X[[g]]
    nsize <- nrow(Data)

    # create the lists of matrices
    univariateProb[[g]] <- matrix(0, nrow = nsize, ncol = sum(nlev))
    pairwiseProb[[g]] <- matrix(0,
      nrow = nsize,
      ncol = length(lavobject@Cache[[g]]$bifreq)
    )

    idx.MissVar.casewise <- apply(Data, 1, function(x) {
      which(is.na(x))
    })

    for (i in 1:nsize) {
      idx.MissVar <- idx.MissVar.casewise[[i]]
      noMissVar <- length(idx.MissVar)

      if (noMissVar > 0L) {
        # compute the denominator of the conditional probability
        TH.VAR <- lapply(1:nvar, function(x) c(-Inf, TH.g[th.idx.g == x], +Inf))
        lower <- sapply(1:nvar, function(x) TH.VAR[[x]][Data[i, x]])
        upper <- sapply(1:nvar, function(x) TH.VAR[[x]][Data[i, x] + 1L])
        lower.denom <- lower[-idx.MissVar]
        upper.denom <- upper[-idx.MissVar]
        MEAN.i <- MEAN[-idx.MissVar]
        Corhat.i <- Cor.hat.g[-idx.MissVar, -idx.MissVar, drop = FALSE]
        denom <- sadmvn(lower.denom, upper.denom, mean = MEAN.i, varcov = Corhat.i)[1]
      } # end of if( noMissVar>0L )

      if (noMissVar == 1L) { # only univariate probabilities for one item
        # compute the numerator
        TH.MissVar <- c(-Inf, TH.g[th.idx.g == idx.MissVar], +Inf)
        # for all response categories of the missing item
        no.cat <- nlev[idx.MissVar]
        numer <- sapply(1:no.cat, function(x) {
          lower[idx.MissVar] <- TH.MissVar[x]
          upper[idx.MissVar] <- TH.MissVar[x + 1L]
          sadmvn(lower, upper, mean = MEAN, varcov = Cor.hat.g)[1]
        })
        idx.columnsUni <- which(idx.uniy %in% idx.MissVar)
        univariateProb[[g]][i, idx.columnsUni] <- numer / denom
      } # end of if( noMissVar==1L )

      if (noMissVar > 1L) {
        # compute the bivariate probabilities and based on them
        # calculate the univariate ones

        # form all possible pairs of items with missing values
        idx.pairsMiss <- combn(idx.MissVar, 2)
        no.pairs <- ncol(idx.pairsMiss)
        for (j in 1:no.pairs) {
          idx.Missy1y2 <- idx.pairsMiss[, j]
          idx.Missy1 <- idx.Missy1y2[1]
          idx.Missy2 <- idx.Missy1y2[2]
          idx.MissRestItems <- idx.MissVar[!(idx.MissVar %in% idx.Missy1y2)]
          TH.Missy1 <- c(-Inf, TH.g[th.idx.g == idx.Missy1], +Inf)
          TH.Missy2 <- c(-Inf, TH.g[th.idx.g == idx.Missy2], +Inf)
          no.cat.Missy1 <- nlev[idx.Missy1]
          no.cat.Missy2 <- nlev[idx.Missy2]
          no.bivRespCat <- no.cat.Missy1 * no.cat.Missy2
          mat_bivRespCat <- matrix(1:no.bivRespCat,
            nrow = no.cat.Missy1,
            ncol = no.cat.Missy2
          )

          numer <- sapply(1:no.bivRespCat, function(x) {
            idx_y1_cat <- which(mat_bivRespCat == x, arr.ind = TRUE)[1]
            idx_y2_cat <- which(mat_bivRespCat == x, arr.ind = TRUE)[2]
            lower[idx.Missy1y2] <-
              c(TH.Missy1[idx_y1_cat], TH.Missy2[idx_y2_cat])
            upper[idx.Missy1y2] <-
              c(TH.Missy1[idx_y1_cat + 1L], TH.Missy2[idx_y2_cat + 1L])
            lower.tmp <- lower
            upper.tmp <- upper
            MEAN.tmp <- MEAN
            Cor.hat.g.tmp <- Cor.hat.g
            if (length(idx.MissRestItems) > 0) {
              lower.tmp <- lower[-idx.MissRestItems]
              upper.tmp <- upper[-idx.MissRestItems]
              MEAN.tmp <- MEAN[-idx.MissRestItems]
              Cor.hat.g.tmp <- Cor.hat.g[-idx.MissRestItems, -idx.MissRestItems]
            }
            sadmvn(lower.tmp, upper.tmp,
              mean = MEAN.tmp, varcov = Cor.hat.g.tmp
            )[1]
          })

          idx.columns <- which((idx.y1 == idx.Missy1) &
            (idx.y2 == idx.Missy2))
          tmp_biv <- numer / denom
          pairwiseProb[[g]][i, idx.columns] <- tmp_biv

          # compute the univariateProb based on the above bivariate
          # probabilities
          if (j == 1L) {
            univariateProb[[g]][i, which(idx.uniy %in% idx.Missy1)] <-
              apply(mat_bivRespCat, 1, function(x) {
                sum(tmp_biv[x])
              })

            univariateProb[[g]][i, which(idx.uniy %in% idx.Missy2)] <-
              apply(mat_bivRespCat, 2, function(x) {
                sum(tmp_biv[x])
              })
          }

          if (j > 1L & j < noMissVar) {
            univariateProb[[g]][i, which(idx.uniy %in% idx.Missy2)] <-
              apply(mat_bivRespCat, 2, function(x) {
                sum(tmp_biv[x])
              })
          }
        } # end of for(j in 1:no.pairs ) #no.pairs is that of missing items
      } # end of if( noMissVar>1L )
    } # end of for(i in 1:nsize)
  } # end of for(g in 1:ngroups)

  list(
    univariateProbGivObs = univariateProb,
    pairwiseProbGivObs = pairwiseProb
  )
} # end of function

lav_model_sigma <- function(lavmodel = NULL, GLIST = NULL, extra = FALSE,
                            delta = TRUE) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  # check.sigma.pd -- new in 0.6-21
  check.sigma.pd <- get0("opt.check.sigma.pd", lavaan_cache_env,
                         ifnotfound = "chol")

  nmat <- lavmodel@nmat
  nblocks <- lavmodel@nblocks
  representation <- lavmodel@representation

  # return a list
  Sigma.hat <- vector("list", length = nblocks)

  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (representation == "LISREL") {
      Sigma.hat[[g]] <- lav_lisrel_sigma(
        MLIST = MLIST,
        delta = delta
      )
    } else if (representation == "RAM") {
      Sigma.hat[[g]] <- lav_ram_sigmahat(MLIST = MLIST, delta = delta)
    } else {
      lav_msg_stop(gettext(
        "only LISREL and RAM representation has been implemented for now"))
    }
    if (lav_debug()) print(Sigma.hat[[g]])

    if (extra) {
      # check if matrix is positive definite
      if (check.sigma.pd == "chol") {
        # fast path: try Cholesky directly
        cS <- tryCatch(chol(Sigma.hat[[g]]), error = function(e) NULL)
        is_pd <- !is.null(cS)
      } else {
        # slow path: eigenvalue-based PD check
        ev <- eigen(Sigma.hat[[g]], symmetric = TRUE, only.values = TRUE)$values
        is_pd <- !(any(ev < sqrt(.Machine$double.eps)) || sum(ev) == 0)
      }
      if (!is_pd) {
        Sigma.hat.inv <- MASS::ginv(Sigma.hat[[g]])
        Sigma.hat.log.det <- log(.Machine$double.eps)
        attr(Sigma.hat[[g]], "po") <- FALSE
        attr(Sigma.hat[[g]], "inv") <- Sigma.hat.inv
        attr(Sigma.hat[[g]], "log.det") <- Sigma.hat.log.det
      } else {
        if (check.sigma.pd != "chol") {
          cS <- chol(Sigma.hat[[g]])
        }
        Sigma.hat.inv <- chol2inv(cS)
        d <- diag(cS)
        Sigma.hat.log.det <- 2 * sum(log(d))
        attr(Sigma.hat[[g]], "po") <- TRUE
        attr(Sigma.hat[[g]], "inv") <- Sigma.hat.inv
        attr(Sigma.hat[[g]], "log.det") <- Sigma.hat.log.det
      }
    }
  } # nblocks
  Sigma.hat
}

## only if conditional.x = TRUE
## compute the (larger) unconditional 'joint' covariance matrix (y,x)
##
## Sigma (Joint ) = [ (S11, S12),
##                    (S21, S22) ] where
##     S11 = Sigma.res + PI %*% cov.x %*% t(PI)
##     S12 = PI %*% cov.x
##     S21 = cov.x %*% t(PI)
##     S22 = cov.x
lav_model_cond2joint_sigma <- function(lavmodel = NULL, GLIST = NULL,
                                       extra = FALSE, delta = TRUE) {
  stopifnot(lavmodel@conditional.x)

  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  # check.sigma.pd -- new in 0.6-21
  check.sigma.pd <- get0("opt.check.sigma.pd", lavaan_cache_env,
                         ifnotfound = "chol")

  nmat <- lavmodel@nmat
  nblocks <- lavmodel@nblocks
  representation <- lavmodel@representation

  # return a list
  Sigma.hat <- vector("list", length = nblocks)

  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (representation == "LISREL") {
      res.Sigma <- lav_lisrel_sigma(MLIST = MLIST, delta = delta)
      # res.int <- lav_lisrel_mu(MLIST = MLIST)
      res.slopes <- lav_lisrel_pi(MLIST = MLIST)
      S.xx <- MLIST$cov.x

      S.yy <- res.Sigma + res.slopes %*% S.xx %*% t(res.slopes)
      S.yx <- res.slopes %*% S.xx
      S.xy <- S.xx %*% t(res.slopes)

      Sigma.hat[[g]] <- rbind(cbind(S.yy, S.yx), cbind(S.xy, S.xx))
    } else {
      lav_msg_stop(gettext(
        "only representation LISREL has been implemented for now"))
    }
    if (lav_debug()) print(Sigma.hat[[g]])

    if (extra) {
      # check if matrix is positive definite
      if (check.sigma.pd == "chol") {
        # fast path: try Cholesky directly
        cS <- tryCatch(chol(Sigma.hat[[g]]), error = function(e) NULL)
        is_pd <- !is.null(cS)
      } else {
        # slow path: eigenvalue-based PD check
        ev <- eigen(Sigma.hat[[g]], symmetric = TRUE, only.values = TRUE)$values
        is_pd <- !(any(ev < sqrt(.Machine$double.eps)) || sum(ev) == 0)
      }
      if (!is_pd) {
        Sigma.hat.inv <- MASS::ginv(Sigma.hat[[g]])
        Sigma.hat.log.det <- log(.Machine$double.eps)
        attr(Sigma.hat[[g]], "po") <- FALSE
        attr(Sigma.hat[[g]], "inv") <- Sigma.hat.inv
        attr(Sigma.hat[[g]], "log.det") <- Sigma.hat.log.det
      } else {
        if (check.sigma.pd != "chol") {
          cS <- chol(Sigma.hat[[g]])
        }
        Sigma.hat.inv <- chol2inv(cS)
        d <- diag(cS)
        Sigma.hat.log.det <- 2 * sum(log(d))
        attr(Sigma.hat[[g]], "po") <- TRUE
        attr(Sigma.hat[[g]], "inv") <- Sigma.hat.inv
        attr(Sigma.hat[[g]], "log.det") <- Sigma.hat.log.det
      }
    }
  } # nblocks

  Sigma.hat
}

lav_model_mu <- function(lavmodel = NULL, GLIST = NULL) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  nmat <- lavmodel@nmat
  nblocks <- lavmodel@nblocks
  representation <- lavmodel@representation
  meanstructure <- lavmodel@meanstructure

  # return a list
  Mu.hat <- vector("list", length = nblocks)

  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (!meanstructure) {
      Mu.hat[[g]] <- numeric(lavmodel@nvar[g])
    } else if (representation == "LISREL") {
      Mu.hat[[g]] <- lav_lisrel_mu(MLIST = MLIST)
    } else if (representation == "RAM") {
      Mu.hat[[g]] <- lav_ram_muhat(MLIST = MLIST)
    } else {
      lav_msg_stop(gettext(
        "only RAM and LISREL representation has been implemented for now"))
    }

    # new in 0.6-20: if a variable is ordinal, set its mean to zero
    # (even if NU is not all zero, as in a multiple group analysis with
    # group.equal = "thresholds")
    #
    # the logic is: Mu.hat is about 'y', not 'y-star'
    # the non-free intercepts (in TAU) are used when computing the
    # model-implied thresholds, but the do not say anything about the
    # 'observed' mean of 'y'
    if (lavmodel@categorical) {
      ord.idx <- unique(lavmodel@th.idx[[g]][lavmodel@th.idx[[g]] > 0L])
      Mu.hat[[g]][ord.idx] <- 0
    }
  } # nblocks

  Mu.hat
}

## only if conditional.x = TRUE
## compute the (larger) unconditional 'joint' mean vector (y,x)
##
## Mu (Joint ) = [ Mu.y, Mu.x ] where
##     Mu.y = res.int + PI %*% M.x
##     Mu.x = M.x
lav_model_cond2joint_mu <- function(lavmodel = NULL, GLIST = NULL) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  # check.sigma.pd -- new in 0.6-21
  check.sigma.pd <- get0("opt.check.sigma.pd", lavaan_cache_env,
                         ifnotfound = "chol")

  nmat <- lavmodel@nmat
  nblocks <- lavmodel@nblocks
  representation <- lavmodel@representation
  meanstructure <- lavmodel@meanstructure

  # return a list
  Mu.hat <- vector("list", length = nblocks)

  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]

    if (!meanstructure) {
      Mu.hat[[g]] <- numeric(lavmodel@nvar[g])
    } else if (representation == "LISREL") {
      MLIST <- GLIST[mm.in.group]
      res.int <- lav_lisrel_mu(MLIST = MLIST)
      res.slopes <- lav_lisrel_pi(MLIST = MLIST)
      M.x <- MLIST$mean.x

      Mu.y <- res.int + res.slopes %*% M.x
      Mu.x <- M.x
      Mu.hat[[g]] <- c(Mu.y, Mu.x)
    } else {
      lav_msg_stop(gettext(
        "only representation LISREL has been implemented for now"))
    }
  } # nblocks

  Mu.hat
}

# TH.star = DELTA.star * (th.star - pi0.star)
# see Muthen 1984 eq 11
lav_model_th <- function(lavmodel = NULL, GLIST = NULL, delta = TRUE) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  nblocks <- lavmodel@nblocks
  nmat <- lavmodel@nmat
  representation <- lavmodel@representation
  th.idx <- lavmodel@th.idx

  # return a list
  TH <- vector("list", length = nblocks)

  # compute TH for each group
  for (g in 1:nblocks) {
    if (length(th.idx[[g]]) == 0) {
      TH[[g]] <- numeric(0L)
      next
    }

    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]

    if (representation == "LISREL") {
      TH[[g]] <- lav_lisrel_th(
        MLIST = GLIST[mm.in.group],
        th.idx = th.idx[[g]], delta = delta
      )
    } else {
      lav_msg_stop(gettext(
        "only representation LISREL has been implemented for now"))
    }
  }

  TH
}

# PI = slope structure
# see Muthen 1984 eq 12
lav_model_pi <- function(lavmodel = NULL, GLIST = NULL, delta = TRUE) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  nblocks <- lavmodel@nblocks
  nmat <- lavmodel@nmat
  representation <- lavmodel@representation
  conditional.x <- lavmodel@conditional.x

  # return a list
  PI <- vector("list", length = nblocks)

  # compute TH for each group
  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (!conditional.x) {
      PI.g <- numeric(lavmodel@nvar[g])
    } else if (representation == "LISREL") {
      PI.g <- lav_lisrel_pi(MLIST = MLIST, delta = delta)
    } else {
      lav_msg_stop(gettext(
        "only representation LISREL has been implemented for now"))
    }

    PI[[g]] <- PI.g
  }

  PI
}


# GW = group weight
lav_model_gw <- function(lavmodel = NULL, GLIST = NULL) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  nblocks <- lavmodel@nblocks
  nmat <- lavmodel@nmat
  representation <- lavmodel@representation
  group.w.free <- lavmodel@group.w.free

  # return a list
  GW <- vector("list", length = nblocks)

  # compute GW for each group
  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (!group.w.free) {
      GW.g <- 0.0 # FIXME
    } else if (representation == "LISREL") {
      GW.g <- as.numeric(MLIST$gw[1, 1])
    } else {
      lav_msg_stop(gettext(
        "only representation LISREL has been implemented for now"))
    }

    GW[[g]] <- GW.g
  }

  # transform to proportions
  # gw <- unlist(GW)
  # gw <- exp(gw) / sum(exp(gw))
  # for(g in 1:nblocks) {
  #    GW[[g]] <- gw[g]
  # }

  GW
}

# *unconditional* variance/covariance matrix of Y
#  - same as Sigma.hat if all Y are continuous)
#  - if also Gamma, cov.x is used (only if categorical)
lav_model_vy <- function(lavmodel = NULL, GLIST = NULL, diagonal.only = FALSE) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  nblocks <- lavmodel@nblocks
  nmat <- lavmodel@nmat
  representation <- lavmodel@representation

  # return a list
  VY <- vector("list", length = nblocks)

  # compute TH for each group
  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (representation == "LISREL") {
      VY.g <- lav_lisrel_vy(MLIST = MLIST)
    } else if (representation == "RAM") {
      # does not work for categorical setting yet
      stopifnot(!lavmodel@categorical)
      # does not work if conditional.x = TRUE
      stopifnot(!lavmodel@conditional.x)
      VY.g <- lav_ram_sigmahat(MLIST = MLIST)
    } else {
      lav_msg_stop(gettext(
        "only RAM and LISREL representation has been implemented for now"))
    }

    if (diagonal.only) {
      VY[[g]] <- diag(VY.g)
    } else {
      VY[[g]] <- VY.g
    }
  }

  VY
}

# V(ETA): latent variances variances/covariances
lav_model_veta <- function(lavmodel = NULL, GLIST = NULL,
                           remove.dummy.lv = FALSE) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  nblocks <- lavmodel@nblocks
  nmat <- lavmodel@nmat
  representation <- lavmodel@representation

  # return a list
  VETA <- vector("list", length = nblocks)

  # compute VETA for each group
  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (representation == "LISREL") {
      VETA.g <- lav_lisrel_veta(MLIST = MLIST)

      if (remove.dummy.lv) {
        # remove all dummy latent variables
        lv.idx <- c(
          lavmodel@ov.y.dummy.lv.idx[[g]],
          lavmodel@ov.x.dummy.lv.idx[[g]]
        )
        if (!is.null(lv.idx)) {
          VETA.g <- VETA.g[-lv.idx, -lv.idx, drop = FALSE]
        }
      }
    } else if (representation == "RAM") {
      VETA.g <- lav_ram_veta(MLIST = MLIST)
    } else {
      lav_msg_stop(gettext(
        "only LISREL and RAM representation has been implemented for now"))
    }

    VETA[[g]] <- VETA.g
  }

  VETA
}

# V(ETA|x_i): latent variances variances/covariances, conditional on x_
# - this is always (I-B)^-1 PSI (I-B)^-T, after REMOVING lv dummies
lav_model_vetax <- function(lavmodel = NULL, GLIST = NULL) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  nblocks <- lavmodel@nblocks
  nmat <- lavmodel@nmat
  representation <- lavmodel@representation

  # return a list
  ETA <- vector("list", length = nblocks)

  # compute ETA for each group
  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (representation == "LISREL") {
      lv.idx <- c(
        lavmodel@ov.y.dummy.lv.idx[[g]],
        lavmodel@ov.x.dummy.lv.idx[[g]]
      )
      ETA.g <- lav_lisrel_vetax(
        MLIST = MLIST,
        lv.dummy.idx = lv.idx
      )
    } else {
      lav_msg_stop(gettext(
        "only representation LISREL has been implemented for now"))
    }

    ETA[[g]] <- ETA.g
  }

  ETA
}

# COV: observed+latent variances variances/covariances
lav_model_cov_both <- function(lavmodel = NULL, GLIST = NULL,
                               remove.dummy.lv = FALSE, delta = TRUE) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  nblocks <- lavmodel@nblocks
  nmat <- lavmodel@nmat
  representation <- lavmodel@representation

  # return a list
  COV <- vector("list", length = nblocks)

  # compute COV for each group
  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (representation == "LISREL") {
      COV.g <- lav_lisrel_cov_both(MLIST = MLIST, delta = delta)

      if (remove.dummy.lv) {
        # remove all dummy latent variables
        lv.idx <- c(
          lavmodel@ov.y.dummy.lv.idx[[g]],
          lavmodel@ov.x.dummy.lv.idx[[g]]
        )
        if (!is.null(lv.idx)) {
          # offset for ov
          lambda.names <-
            lavmodel@dimNames[[which(names(GLIST) == "lambda")[g]]][[1L]]
          lv.idx <- lv.idx + length(lambda.names)
          COV.g <- COV.g[-lv.idx, -lv.idx, drop = FALSE]
        }
      }
    } else {
      lav_msg_stop(gettext(
        "only representation LISREL has been implemented for now"))
    }

    COV[[g]] <- COV.g
  }

  COV
}


# E(ETA): expectation (means) of latent variables (return vector)
lav_model_eeta <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL,
                           remove.dummy.lv = FALSE) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  nblocks <- lavmodel@nblocks
  nmat <- lavmodel@nmat
  representation <- lavmodel@representation

  # return a list
  EETA <- vector("list", length = nblocks)

  # compute E(ETA) for each group
  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (representation == "LISREL") {
      EETA.g <- lav_lisrel_eeta(MLIST,
        mean.x = lavsamplestats@mean.x[[g]],
        sample.mean = lavsamplestats@mean[[g]],
        ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
        ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]],
        ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
        ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]]
      )
      if (remove.dummy.lv) {
        # remove dummy
        lv.dummy.idx <- c(
          lavmodel@ov.y.dummy.lv.idx[[g]],
          lavmodel@ov.x.dummy.lv.idx[[g]]
        )
        if (length(lv.dummy.idx) > 0L) {
          EETA.g <- EETA.g[-lv.dummy.idx]
        }
      }
    } else {
      lav_msg_stop(gettext(
        "only representation LISREL has been implemented for now"))
    }

    EETA[[g]] <- EETA.g
  }

  EETA
}

# E(ETA|x_i): conditional expectation (means) of latent variables
# for a given value of x_i (instead of E(x_i))
lav_model_eetax <- function(lavmodel = NULL, GLIST = NULL,
                            lavsamplestats = NULL, eXo = NULL,
                            nobs = NULL, remove.dummy.lv = FALSE) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  nblocks <- lavmodel@nblocks
  nmat <- lavmodel@nmat
  representation <- lavmodel@representation

  # return a list
  EETAx <- vector("list", length = nblocks)

  # compute E(ETA) for each group
  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    EXO <- eXo[[g]]
    if (is.null(EXO)) {
      # create empty matrix
      EXO <- matrix(0, nobs[[g]], 0L)
    }

    if (representation == "LISREL") {
      EETAx.g <- lav_lisrel_eetax(MLIST,
        eXo = EXO, N = nobs[[g]],
        sample.mean = lavsamplestats@mean[[g]],
        ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
        ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]],
        ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
        ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]]
      )

      if (remove.dummy.lv) {
        # remove dummy
        lv.dummy.idx <- c(
          lavmodel@ov.y.dummy.lv.idx[[g]],
          lavmodel@ov.x.dummy.lv.idx[[g]]
        )
        if (length(lv.dummy.idx) > 0L) {
          EETAx.g <- EETAx.g[, -lv.dummy.idx, drop = FALSE]
        }
      }
    } else {
      lav_msg_stop(gettext(
        "only representation LISREL has been implemented for now"))
    }

    EETAx[[g]] <- EETAx.g
  }

  EETAx
}

# return 'regular' LAMBDA
lav_model_lambda <- function(lavmodel = NULL, GLIST = NULL,
                             handle.dummy.lv = TRUE,
                             remove.dummy.lv = FALSE) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  nblocks <- lavmodel@nblocks
  nmat <- lavmodel@nmat
  representation <- lavmodel@representation

  # return a list
  LAMBDA <- vector("list", length = nblocks)

  # compute LAMBDA for each group
  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (representation == "LISREL") {
      if (handle.dummy.lv) {
        ov.y.dummy.ov.idx <- lavmodel@ov.y.dummy.ov.idx[[g]]
        ov.x.dummy.ov.idx <- lavmodel@ov.x.dummy.ov.idx[[g]]
        ov.y.dummy.lv.idx <- lavmodel@ov.y.dummy.lv.idx[[g]]
        ov.x.dummy.lv.idx <- lavmodel@ov.x.dummy.lv.idx[[g]]
      } else {
        ov.y.dummy.ov.idx <- NULL
        ov.x.dummy.ov.idx <- NULL
        ov.y.dummy.lv.idx <- NULL
        ov.x.dummy.lv.idx <- NULL
      }
      LAMBDA.g <- lav_lisrel_lambda(
        MLIST = MLIST,
        ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
        ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
        ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
        ov.x.dummy.lv.idx = ov.x.dummy.lv.idx,
        remove.dummy.lv = remove.dummy.lv
      )
    } else {
      lav_msg_stop(gettext(
        "only representation LISREL has been implemented for now"))
    }

    LAMBDA[[g]] <- LAMBDA.g
  }

  LAMBDA
}

# THETA: observed (residual) variances
lav_model_theta <- function(lavmodel = NULL, GLIST = NULL, fix = TRUE) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  nblocks <- lavmodel@nblocks
  nmat <- lavmodel@nmat
  representation <- lavmodel@representation

  # return a list
  THETA <- vector("list", length = nblocks)

  # compute THETA for each group
  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (representation == "LISREL") {
      if (fix) {
        THETA.g <- lav_lisrel_theta(
          MLIST = MLIST,
          ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
          ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
          ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
          ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]]
        )
      } else {
        THETA.g <- lav_lisrel_theta(MLIST = MLIST)
      }
    } else if (representation == "RAM") {
      ov.idx <- as.integer(MLIST$ov.idx[1, ])
      THETA.g <- MLIST$S[ov.idx, ov.idx, drop = FALSE]
    } else {
      lav_msg_stop(gettext(
        "only LISREL and RAM representation has been implemented for now"))
    }

    THETA[[g]] <- THETA.g
  }

  THETA
}

# NU: observed intercepts
lav_model_nu <- function(lavmodel = NULL, GLIST = NULL,
                         lavsamplestats = NULL) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  nblocks <- lavmodel@nblocks
  nmat <- lavmodel@nmat
  representation <- lavmodel@representation

  # return a list
  NU <- vector("list", length = nblocks)

  # compute NU for each group
  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (representation == "LISREL") {
      NU.g <- lav_lisrel_nu(
        MLIST = MLIST,
        sample.mean = lavsamplestats@mean[[g]],
        ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
        ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
        ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
        ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]]
      )
    } else {
      lav_msg_stop(gettext(
        "only representation LISREL has been implemented for now"))
    }

    NU[[g]] <- as.matrix(NU.g)
  }

  NU
}

# E(Y): expectation (mean) of observed variables
# returns vector 1 x nvar
lav_model_ey <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL,
                         delta = TRUE) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  nblocks <- lavmodel@nblocks
  nmat <- lavmodel@nmat
  representation <- lavmodel@representation

  # return a list
  EY <- vector("list", length = nblocks)

  # compute E(Y) for each group
  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (representation == "LISREL") {
      EY.g <- lav_lisrel_ey(
        MLIST = MLIST,
        mean.x = lavsamplestats@mean.x[[g]],
        sample.mean = lavsamplestats@mean[[g]],
        ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
        ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
        ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
        ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]],
        delta = delta
      )
    } else {
      lav_msg_stop(gettext(
        "only representation LISREL has been implemented for now"))
    }

    EY[[g]] <- EY.g
  }

  EY
}

# E(Y|x_i): conditional expectation (mean) of observed variables
# returns matrix N x nvar
lav_model_eyx <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL,
                          eXo = NULL, delta = TRUE) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  nblocks <- lavmodel@nblocks
  nmat <- lavmodel@nmat
  representation <- lavmodel@representation

  # return a list
  EYx <- vector("list", length = nblocks)

  # compute E(Y) for each group
  for (g in 1:nblocks) {
    # which mm belong to group g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (representation == "LISREL") {
      EYx.g <- lav_lisrel_eyx(
        MLIST = MLIST,
		eXo = eXo[[g]],
        sample.mean = lavsamplestats@mean[[g]],
        ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
        ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
        ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
        ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]],
        delta = delta
      )
    } else {
      lav_msg_stop(gettext(
        "only representation LISREL has been implemented for now"))
    }

    EYx[[g]] <- EYx.g
  }

  EYx
}


# E(Y | ETA, x_i): conditional expectation (means) of observed variables
# for a given value of x_i AND eta_i
lav_model_yhat <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL,
                           eXo = NULL, nobs = NULL, ETA = NULL,
                           duplicate = FALSE, delta = TRUE) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  # ngroups, not nblocks!
  ngroups <- lavsamplestats@ngroups

  # return a list
  YHAT <- vector("list", length = ngroups)

  # compute YHAT for each group
  for (g in seq_len(ngroups)) {
    # which mm belong to group g?
    # FIXME: what if more than g blocks???
    mm.in.group <- 1:lavmodel@nmat[g] + cumsum(c(0L, lavmodel@nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (is.null(eXo[[g]]) && duplicate) {
      Nobs <- nobs[[g]]
    } else {
      Nobs <- 1L
    }

    if (lavmodel@representation == "LISREL") {
      if (lavmodel@conditional.x) {
        YHAT[[g]] <- lav_lisrel_eyetax(
          MLIST = MLIST,
          eXo = eXo[[g]], ETA = ETA[[g]], N = Nobs,
          sample.mean = lavsamplestats@mean[[g]],
          ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
          ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
          ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
          ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]],
          delta = delta
        )
      } else {
        # unconditional case
        YHAT[[g]] <- lav_lisrel_eyetax3(
          MLIST = MLIST,
          ETA = ETA[[g]],
          sample.mean = lavsamplestats@mean[[g]],
          mean.x = lavsamplestats@mean.x[[g]],
          ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
          ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
          ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
          ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]],
          delta = delta
        )
        # impute back ov.y values that are NOT indicators
      }
    } else {
      lav_msg_stop(gettextf("representation %s not supported yet.",
                            lavmodel@representation))
    }
  }

  YHAT
}

# main function used by various bootstrap related functions
# this function draws the bootstrap samples, and estimates the
# free parameters for each bootstrap sample
#
# return COEF matrix of size R x npar (R = number of bootstrap samples)
#
# Ed. 9 mar 2012
#
# Notes: - faulty runs are simply ignored (with a warning)
#        - default R=1000
#
# Updates: - now we have a separate @Data slot, we only need to transform once
#            for the bollen.stine bootstrap (13 dec 2011)
#          - bug fix: we need to 'update' the fixed.x variances/covariances
#            for each bootstrap draw!!
#
# Question: if fixed.x=TRUE, should we not keep X fixed, and bootstrap Y
#           only, conditional on X?? How to implement the conditional part?

# YR 27 Aug 2022: - add keep.idx argument
#                 - always return 'full' set of bootstrap results, including
#                   failed runs (as NAs)
#                 - idx nonadmissible/error solutions as an attribute
#                 - thanks to keep.idx, it is easy to replicate/investigate
#                   these cases if needed

# YR 10 Nov 2024: - detect sam object

lavBootstrap <- function(object,
                            R = 1000L,
                            type = "ordinary",
                            verbose = FALSE,
                            FUN = "coef",
                            # return.boot = FALSE, # no use, as boot stores
                            #                      # sample indices differently
                            keep.idx = FALSE,
                            parallel = c("no", "multicore", "snow"),
                            ncpus = max(1L, parallel::detectCores() - 2L),
                            cl = NULL,
                            iseed = NULL,
                            h0.rmsea = NULL,
                            ...) {

  # check object
  object <- lav_object_check_version(object)

  # checks
  type. <- tolower(type) # overwritten if nonparametric
  stopifnot(
    inherits(object, "lavaan"),
    type. %in% c(
      "nonparametric", "ordinary",
      "bollen.stine", "parametric", "yuan"
    )
  )
  if (!missing(verbose)) {
    current.verbose <- lav_verbose()
    if (lav_verbose(verbose))
      on.exit(lav_verbose(current.verbose), TRUE)
  }
  if (type. == "nonparametric") {
    type. <- "ordinary"
  }
  if (missing(parallel)) {
    parallel <- "no"
  }
  parallel <- match.arg(parallel)

  # check if options$se is not bootstrap, otherwise, we get an infinite loop
  if (object@Options$se == "bootstrap") {
    object@Options$se <- "standard"
  }

  # check if options$test is not bollen.stine
  if ("bollen.stine" %in% object@Options$test) {
    object@Options$test <- "standard"
  }

  # check for conditional.x = TRUE
  if (object@Model@conditional.x) {
    lav_msg_stop(gettext(
      "this function is not (yet) available if conditional.x = TRUE"))
  }

  lavoptions. <- list(
    parallel = parallel, ncpus = ncpus, cl = cl,
    iseed = iseed
  )

  out <- lav_bootstrap_internal(
    object = object,
    lavdata. = NULL,
    lavmodel. = NULL,
    lavsamplestats. = NULL,
    lavoptions. = lavoptions.,
    lavpartable. = NULL,
    R = R,
    show.progress = verbose,
    type = type.,
    FUN = FUN,
    keep.idx = keep.idx,
    h0.rmsea = h0.rmsea,
    ...
  )

  # new in 0.6-12: always warn for failed and nonadmissible runs
  nfailed <- length(attr(out, "error.idx")) # zero if NULL
  if (nfailed > 0L) {
    lav_msg_warn(gettextf(
      "%s bootstrap runs failed or did not converge.", nfailed))
  }

  notok <- length(attr(out, "nonadmissible")) # zero if NULL
  if (notok > 0L) {
     lav_msg_warn(gettextf(
      "%s bootstrap runs resulted in nonadmissible solutions.", notok))
  }

  out
}
lavBootstrap <- lavBootstrap  # synonym #nolint

# we need an internal version to be called from VCOV and lav_model_test
# when there is no lavaan object yet!
lav_bootstrap_internal <- function(object = NULL,
                                   lavdata. = NULL,
                                   lavmodel. = NULL,
                                   lavsamplestats. = NULL,
                                   lavoptions. = NULL,
                                   lavpartable. = NULL,
                                   R = 1000L,
                                   show.progress = FALSE,
                                   type = "ordinary",
                                   FUN = "coef",
                                   check.post = TRUE,
                                   keep.idx = FALSE,
                                   # return.boot     = FALSE,
                                   h0.rmsea = NULL,
                                   ...) {
  # warning: avoid use of 'options', 'sample' (both are used as functions
  # below...
  # options -> opt
  # sample -> samp

  mc <- match.call()

  # object slots
  FUN.orig <- FUN
  has.sam.object.flag <- FALSE
  if (!is.null(object)) {
    stopifnot(inherits(object, "lavaan"))
    # check for sam object
    if (!is.null(object@internal$sam.method)) {
      has.sam.object.flag <- TRUE
    }
    lavdata <- object@Data
    lavmodel <- object@Model
    lavsamplestats <- object@SampleStats
    lavoptions <- object@Options
    if (!is.null(lavoptions.)) {
      lavoptions$parallel <- lavoptions.$parallel
      lavoptions$ncpus <- lavoptions.$ncpus
      lavoptions$cl <- lavoptions.$cl
      lavoptions$iseed <- lavoptions.$iseed
    }
    lavpartable <- object@ParTable
    FUN <- match.fun(FUN)
    t0 <- FUN(object, ...)
    t.star <- matrix(as.numeric(NA), R, length(t0))
    colnames(t.star) <- names(t0)
  } else {
    # internal version!
    lavdata <- lavdata.
    lavmodel <- lavmodel.
    lavsamplestats <- lavsamplestats.
    lavoptions <- lavoptions.
    lavpartable <- lavpartable.
    if (FUN == "coef") {
      t.star <- matrix(as.numeric(NA), R, lavmodel@nx.free)
      lavoptions$test <- "none"
    } else if (FUN == "test") {
      t.star <- matrix(as.numeric(NA), R, 1L)
      lavoptions$test <- "standard"
    } else if (FUN == "coeftest") {
      t.star <- matrix(as.numeric(NA), R, lavmodel@nx.free + 1L)
      lavoptions$test <- "standard"
    }
  }

  # always shut off some options:
  current.verbose <- lav_verbose()
  if (missing(show.progress)) {
    show.progress <- current.verbose
  }
  if (lav_verbose(FALSE)) on.exit(lav_verbose(current.verbose))
  lavoptions$check.start <- FALSE
  lavoptions$check.post <- FALSE
  lavoptions$optim.attempts <- 1L # can save a lot of time

  # if internal or FUN == "coef", we can shut off even more
  if (is.null(object) || (is.character(FUN.orig) && FUN.orig == "coef")) {
    lavoptions$baseline <- FALSE
    lavoptions$h1 <- FALSE
    lavoptions$loglik <- FALSE
    lavoptions$implied <- FALSE
    lavoptions$store.vcov <- FALSE
    lavoptions$se <- "none"
    if (FUN.orig == "coef") {
      lavoptions$test <- "none"
    }
  }

  # bollen.stine, yuan, or parametric: we need the Sigma.hat values
  if (type == "bollen.stine" || type == "parametric" || type == "yuan") {
    Sigma.hat <- lav_model_sigma(lavmodel = lavmodel)
    Mu.hat <- lav_model_mu(lavmodel = lavmodel)
  }

  # can we use the original data, or do we need to transform it first?
  if (type == "bollen.stine" || type == "yuan") {
    # check if data is continuous
    if (lavmodel@categorical) {
      lav_msg_stop(gettext(
        "bollen.stine/yuan bootstrap not available for categorical/ordinal data"
        ))
    }
    # check if data is complete
    if (lavoptions$missing != "listwise") {
      lav_msg_stop(gettext(
        "bollen.stine/yuan bootstrap not available for missing data"))
    }
    dataX <- vector("list", length = lavdata@ngroups)
  } else {
    dataX <- lavdata@X
  }

  # if bollen.stine, transform data here
  if (type == "bollen.stine") {
    for (g in 1:lavsamplestats@ngroups) {
      sigma.sqrt <- lav_matrix_symmetric_sqrt(Sigma.hat[[g]])
      S.inv.sqrt <- lav_matrix_symmetric_sqrt(lavsamplestats@icov[[g]])

      # center (needed???)
      X <- scale(lavdata@X[[g]], center = TRUE, scale = FALSE)

      # transform
      X <- X %*% S.inv.sqrt %*% sigma.sqrt

      # add model-based mean
      if (lavmodel@meanstructure) {
        X <- scale(X, center = (-1 * Mu.hat[[g]]), scale = FALSE)
      }

      # transformed data
      dataX[[g]] <- X
    }

    # if yuan, transform data here
  } else if (type == "yuan") {
    # page numbers refer to Yuan et al, 2007
    # Define a function to find appropriate value of a
    # (p. 272); code supplied 16 jun 2016 by Cheng & Wu
    search.a <- function(F0, d, p) {
      if (F0 == 0) {
        a0 <- 0
        return(a0)
      }
      max.a <- 1 / (1 - min(d)) - 1e-3
      # starting value; Yuan p. 272
      a0 <- min(sqrt(2 * F0 / sum((d - 1)^2)), max.a)

      # See Yuan p. 280
      for (i in 1:50) {
        dia <- a0 * d + (1 - a0)
        g1 <- -sum(log(dia)) + sum(dia) - p
        dif <- g1 - F0
        if (abs(dif) < 1e-6) {
          return(a0)
        }
        g2 <- a0 * sum((d - 1)^2 / dia)
        a0 <- min(max(a0 - dif / g2, 0), max.a)
      }
      # if search fails to converge in 50 iterations
      lav_msg_warn(gettext("yuan bootstrap search for `a` did not converge.
                           h0.rmsea may be too large."))
      a0
    }

    # Now use g.a within each group
    for (g in 1:lavsamplestats@ngroups) {
      S <- lavsamplestats@cov[[g]]
      # test is in Fit slot
      ghat <- object@test[[1]]$stat.group[[g]]
      df <- object@test[[1]]$df
      Sigmahat <- Sigma.hat[[g]]
      nmv <- nrow(Sigmahat)
      n <- nrow(lavdata@X[[g]])

      # Calculate tauhat_1, middle p. 267.
      # Yuan et al note that tauhat_1 could be negative;
      # if so, we need to let S.a = Sigmahat. (see middle p 275)
      ifelse(length(h0.rmsea) == 0,
        tau.hat <- (ghat - df) / (n - 1), # middle p 267
        tau.hat <- df * (h0.rmsea * h0.rmsea)
      ) # middle p 273

      if (tau.hat >= 0) {
        # from Cheng and Wu
        EL <- t(chol(Sigmahat))
        ESE <- forwardsolve(EL, t(forwardsolve(EL, S)))
        d <- eigen(ESE, symmetric = TRUE, only.values = TRUE)$values
        if ("a" %in% names(list(...))) {
          a <- list(...)$a
        } else {
          # Find a to minimize g.a
          a <- search.a(tau.hat, d, nmv)
        }
        # Calculate S_a (p. 267)
        S.a <- a * S + (1 - a) * Sigmahat
      } else {
        S.a <- Sigmahat
      }

      # Transform the data (p. 263)
      S.a.sqrt <- lav_matrix_symmetric_sqrt(S.a)
      S.inv.sqrt <- lav_matrix_symmetric_sqrt(lavsamplestats@icov[[g]])

      X <- lavdata@X[[g]]
      X <- X %*% S.inv.sqrt %*% S.a.sqrt

      # transformed data
      dataX[[g]] <- X
    }
  }

  # run bootstraps
  fn <- function(b) {
    # create bootstrap sample, and generate new 'data' object
    if (type == "bollen.stine" || type == "ordinary" || type == "yuan") {
      # take a bootstrap sample for each group
      BOOT.idx <- vector("list", length = lavdata@ngroups)
      # Note: we generate the bootstrap indices separately for each
      #       group, in order to ensure the group sizes do not change!
      for (g in 1:lavdata@ngroups) {
        stopifnot(nrow(lavdata@X[[g]]) > 1L)
        boot.idx <- sample.int(nrow(lavdata@X[[g]]), replace = TRUE)
        BOOT.idx[[g]] <- boot.idx
        dataX[[g]] <- dataX[[g]][boot.idx, , drop = FALSE]
      }
      newData <- lav_data_update(
        lavdata = lavdata, newX = dataX,
        BOOT.idx = BOOT.idx,
        lavoptions = lavoptions
      )
    } else { # parametric! (using sign-invariant method for reproducibility)
      for (g in 1:lavdata@ngroups) {
        dataX[[g]] <- lav_mvrnorm(
          n = lavdata@nobs[[g]],
          Sigma = Sigma.hat[[g]],
          mu = Mu.hat[[g]]
        )
      }
      newData <- lav_data_update(
        lavdata = lavdata, newX = dataX,
        lavoptions = lavoptions
      )
    }

    # show progress?
    if (show.progress) {
      cat("  ... bootstrap draw number:", sprintf("%4d", b))
    }
    bootSampleStats <- try(lav_samplestats_from_data(
      lavdata       = newData,
      lavoptions    = lavoptions
    ), silent = TRUE)
    if (inherits(bootSampleStats, "try-error")) {
      if (show.progress) {
        cat("     FAILED: creating sample statistics\n")
        cat(bootSampleStats[1])
      }
      out <- as.numeric(NA)
      attr(out, "nonadmissible.flag") <- TRUE
      if (keep.idx) {
        attr(out, "BOOT.idx") <- BOOT.idx
      }
      return(out)
    }
    if (has.sam.object.flag) {
      # also need h1
      booth1 <- lav_h1_implied_logl(lavdata = newData,
        lavsamplestats = bootSampleStats, lavpartable = lavpartable,
        lavoptions = lavoptions)
    }

    # do we need to update Model slot? only if we have fixed exogenous
    # covariates, as their variances/covariances are stored in GLIST
    if (lavmodel@fixed.x && length(lav_partable_vnames(lavpartable, "ov.x")) > 0L) {
      model.boot <- NULL
    } else {
      model.boot <- lavmodel
    }

    # fit model on bootstrap sample
    if (has.sam.object.flag) {
      new_object <- object
      new_object@Data <- newData
      new_object@SampleStats <- bootSampleStats
      new_object@h1 <- booth1
      # what about lavoptions?
      fit.boot <- suppressWarnings(try(sam(new_object, se = "none"),
                                       silent = FALSE)) # show what is wrong
    } else {
      fit.boot <- suppressWarnings(try(lavaan(
        slotOptions = lavoptions,
        slotParTable = lavpartable,
        slotModel = model.boot,
        slotSampleStats = bootSampleStats,
        slotData = newData
      ), silent = FALSE))
    }
    if (inherits(fit.boot, "try-error")) {
      if (show.progress) {
        cat("     FAILED: with ERROR message\n")
      }
      out <- as.numeric(NA)
      attr(out, "nonadmissible.flag") <- TRUE
      if (keep.idx) {
        attr(out, "BOOT.idx") <- BOOT.idx
      }
      return(out)
    }
    if (!fit.boot@optim$converged) {
      if (show.progress) {
        cat("     FAILED: no convergence\n")
      }
      out <- as.numeric(NA)
      attr(out, "nonadmissible.flag") <- TRUE
      if (keep.idx) {
        attr(out, "BOOT.idx") <- BOOT.idx
      }
      return(out)
    }

    # extract information we need
    if (is.null(object)) { # internal use only!
      if (FUN == "coef") {
        out <- fit.boot@optim$x
      } else if (FUN == "test") {
        out <- fit.boot@test[[1L]]$stat
      } else if (FUN == "coeftest") {
        out <- c(fit.boot@optim$x, fit.boot@test[[1L]]$stat)
      }
    } else { # general use
      out <- try(as.numeric(FUN(fit.boot, ...)), silent = TRUE)
    }
    if (inherits(out, "try-error")) {
      if (show.progress) {
        cat("     FAILED: applying FUN to fit.boot\n")
      }
      out <- as.numeric(NA)
      attr(out, "nonadmissible.flag") <- TRUE
      if (keep.idx) {
        attr(out, "BOOT.idx") <- BOOT.idx
      }
      return(out)
    }

    # check if the solution is admissible
    admissible.flag <- suppressWarnings(lavInspect(fit.boot, "post.check"))
    attr(out, "nonadmissible.flag") <- !admissible.flag

    if (show.progress) {
      cat(
        "   OK -- niter = ",
        sprintf("%3d", fit.boot@optim$iterations), " fx = ",
        sprintf("%11.9f", fit.boot@optim$fx),
        if (admissible.flag) " " else "n", "\n"
      )
    }

    if (keep.idx) {
      # add BOOT.idx (for all groups)
      attr(out, "BOOT.idx") <- BOOT.idx
    }

    out
  } # end-of-fn

  # get parallelization options
  parallel <- lavoptions$parallel[1]
  ncpus <- lavoptions$ncpus
  cl <- lavoptions[["cl"]] # often NULL
  iseed <- lavoptions[["iseed"]] # often NULL

  # the next 8 lines are borrowed from the boot package
  have_mc <- have_snow <- FALSE
  if (parallel != "no" && ncpus > 1L) {
    if (parallel == "multicore") {
      have_mc <- .Platform$OS.type != "windows"
    } else if (parallel == "snow") have_snow <- TRUE
    if (!have_mc && !have_snow) ncpus <- 1L
    loadNamespace("parallel") # before recording seed!
  }

  # iseed:
  # this follows a proposal of Shu Fai Cheung (see github issue #240)
  # - iseed is used for both serial and parallel
  # - if iseed is not set, iseed is generated + .Random.seed created/updated
  #     -> tmp.seed <- NA
  # - if iseed is set: don't touch .Random.seed (if it exists)
  #     -> tmp.seed <- .Random.seed (if it exists)
  #     -> tmp.seed <- NULL (if it does not exist)
  if (is.null(iseed)) {
    if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
      runif(1)
    }
    # identical(temp.seed, NA): Will not change .Random.seed in GlobalEnv
    temp.seed <- NA
    iseed <- runif(1, 0, 999999999)
  } else {
    if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
      temp.seed <-
        get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
    } else {
      # is.null(temp.seed): Will remove .Random.seed in GlobalEnv
      #                     if serial.
      #                     If parallel, .Random.seed will not be touched.
      temp.seed <- NULL
    }
  }
  if (!(ncpus > 1L && (have_mc || have_snow))) { # Only for serial
    set.seed(iseed)
  }


  # this is adapted from the boot function in package boot
  RR <- R
  if (show.progress) {
    cat("\n")
  }
  res <- if (ncpus > 1L && (have_mc || have_snow)) {
    if (have_mc) {
      RNGkind_old <- RNGkind() # store current kind
      RNGkind("L'Ecuyer-CMRG") # to allow for reproducible results
      set.seed(iseed)
      parallel::mclapply(seq_len(RR), fn, mc.cores = ncpus)
    } else if (have_snow) {
      list(...) # evaluate any promises
      if (is.null(cl)) {
        cl <- parallel::makePSOCKcluster(rep("localhost", ncpus))
        # # No need for
        # if(RNGkind()[1L] == "L'Ecuyer-CMRG")
        # clusterSetRNGStream() always calls `RNGkind("L'Ecuyer-CMRG")`
        parallel::clusterSetRNGStream(cl, iseed = iseed)
        res <- parallel::parLapply(cl, seq_len(RR), fn)
        parallel::stopCluster(cl)
        res
      } else {
        parallel::parLapply(cl, seq_len(RR), fn)
      }
    }
  } else {
    lapply(seq_len(RR), fn)
  }

  # restore old RNGkind()
  if (ncpus > 1L && have_mc) {
    RNGkind(RNGkind_old[1], RNGkind_old[2], RNGkind_old[3])
  }

  # fill in container
  t.star[] <- do.call("rbind", res)

  # handle errors
  error.idx <- which(sapply(res, function(x) is.na(x[1L])))
  attr(t.star, "error.idx") <- error.idx # could be integer(0L)

  # handle nonadmissible solutions
  if (check.post) {
    notok <- which(sapply(res, attr, "nonadmissible.flag"))
    if (length(error.idx) > 0L) {
      notok <- notok[-which(notok %in% error.idx)]
    }
    attr(t.star, "nonadmissible") <- notok
  }

  # store iseed
  attr(t.star, "seed") <- iseed

  # handle temp.seed
  if (!is.null(temp.seed) && !identical(temp.seed, NA)) {
    assign(".Random.seed", temp.seed, envir = .GlobalEnv)
  } else if (is.null(temp.seed) && !(ncpus > 1L && (have_mc || have_snow))) {
    # serial
    rm(.Random.seed, pos = 1)
  } else if (is.null(temp.seed) && (ncpus > 1L && have_mc)) {
    # parallel/multicore only
    rm(.Random.seed, pos = 1) # because set used set.seed()
  }

  # store BOOT.idx per group
  if (keep.idx) {
    BOOT.idx <- vector("list", length = lavsamplestats@ngroups)
    for (g in 1:lavsamplestats@ngroups) {
      # note that failed runs (NULL) are removed (for now)
      BOOT.idx[[g]] <- do.call(
        "rbind",
        lapply(res, function(x) attr(x, "BOOT.idx")[[g]])
      )
    }
    attr(t.star, "boot.idx") <- BOOT.idx
  }

  #    # No use, as boot package stores the sample indices differently
  #    # See boot:::boot.array() versus lav_bootstrap_indices()
  #    if(return.boot) {
  #        # mimic output boot function
  #
  #        if(is.null(object)) {
  #            stop("lavaan ERROR: return.boot = TRUE requires a full lavaan object")
  #        }
  #
  #        # we start with ordinary only for now
  #        stopifnot(type == "ordinary")
  #
  #        if(! type %in% c("ordinary", "parametric")) {
  #            stop("lavaan ERROR: only ordinary and parametric bootstrap are supported if return.boot = TRUE")
  #        } else {
  #            sim <- type
  #        }
  #
  #        statistic. <- function(data, idx) {
  #                         data.boot <- data[idx,]
  #                         fit.boot <- update(object, data = data.boot)
  #                         out <- try(FUN(fit.boot, ...), silent = TRUE)
  #                         if(inherits(out, "try-error")) {
  #                             out <- rep(as.numeric(NA), length(t0))
  #                         }
  #                         out
  #                     }
  #        attr(t.star, "seed") <- NULL
  #        attr(t.star, "nonadmissible") <- NULL
  #        out <- list(t0 = t0, t = t.star, R = RR,
  #                    data = lavInspect(object, "data"),
  #                    seed = iseed, statistic = statistic.,
  #                    sim = sim, call = mc)
  #
  #        #if(sim == "parametric") {
  #        #    ran.gen. <- function() {} # TODO
  #        #    out <- c(out, list(ran.gen = ran.gen, mle = mle))
  #        #} else if(sim == "ordinary") {
  #            stype <- "i"
  #            strata <- rep(1, nobs(object))
  #            weights <- 1/tabulate(strata)[strata]
  #            out <- c(out, list(stype = stype, strata = strata,
  #                                weights = weights))
  #        #}
  #
  #        class(out) <- "boot"
  #        return(out)
  #    }
  #
  t.star
}

# create matrix with indices to reconstruct the bootstrap samples
# per group
# (originally needed for BCa confidence intervals)
#
# rows are the (R) bootstrap runs
# columns are the (N) observations
#
# simple version: no strata, no weights
#
lav_bootstrap_indices <- function(R = 0L,
                                        nobs = list(0L), # per group
                                        parallel = "no",
                                        ncpus = 1L,
                                        cl = NULL,
                                        iseed = NULL,
                                        merge.groups = FALSE,
                                        return.freq = FALSE) {
  # iseed must be set!
  stopifnot(!is.null(iseed))

  if (return.freq && !merge.groups) {
    lav_msg_stop(gettext("return.freq only available if merge.groups = TRUE"))
  }

  if (is.integer(nobs)) {
    nobs <- list(nobs)
  }

  # number of groups
  ngroups <- length(nobs)

  # mimic 'random' sampling from lav_bootstrap_internal:

  # the next 7 lines are borrowed from the boot package
  have_mc <- have_snow <- FALSE
  parallel <- parallel[1]
  if (parallel != "no" && ncpus > 1L) {
    if (parallel == "multicore") {
      have_mc <- .Platform$OS.type != "windows"
    } else if (parallel == "snow") have_snow <- TRUE
    if (!have_mc && !have_snow) ncpus <- 1L
    loadNamespace("parallel") # before recording seed!
  }
  temp.seed <- NULL
  if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
    temp.seed <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
  }
  if (!(ncpus > 1L && (have_mc || have_snow))) { # Only for serial
    set.seed(iseed)
  }

  # fn() returns indices per group
  fn <- function(b) {
    BOOT.idx <- vector("list", length = ngroups)
    OFFSet <- cumsum(c(0, unlist(nobs)))
    for (g in 1:ngroups) {
      stopifnot(nobs[[g]] > 1L)
      boot.idx <- sample.int(nobs[[g]], replace = TRUE)
      if (merge.groups) {
        BOOT.idx[[g]] <- boot.idx + OFFSet[g]
      } else {
        BOOT.idx[[g]] <- boot.idx
      }
    }
    BOOT.idx
  }

  RR <- R
  res <- if (ncpus > 1L && (have_mc || have_snow)) {
    if (have_mc) {
      RNGkind_old <- RNGkind() # store current kind
      RNGkind("L'Ecuyer-CMRG") # to allow for reproducible results
      set.seed(iseed)
      parallel::mclapply(seq_len(RR), fn, mc.cores = ncpus)
    } else if (have_snow) {
      # list(...) # evaluate any promises
      if (is.null(cl)) {
        cl <- parallel::makePSOCKcluster(rep("localhost", ncpus))
        parallel::clusterSetRNGStream(cl, iseed = iseed)
        res <- parallel::parLapply(cl, seq_len(RR), fn)
        parallel::stopCluster(cl)
        res
      } else {
        parallel::parLapply(cl, seq_len(RR), fn)
      }
    }
  } else {
    lapply(seq_len(RR), fn)
  }

  # restore old RNGkind()
  if (ncpus > 1L && have_mc) {
    RNGkind(RNGkind_old[1], RNGkind_old[2], RNGkind_old[3])
  }

  # handle temp.seed
  if (!is.null(temp.seed) && !identical(temp.seed, NA)) {
    assign(".Random.seed", temp.seed, envir = .GlobalEnv)
  } else if (is.null(temp.seed) && !(ncpus > 1L && (have_mc || have_snow))) {
    # serial
    rm(.Random.seed, pos = 1)
  } else if (is.null(temp.seed) && (ncpus > 1L && have_mc)) {
    # parallel/multicore only
    rm(.Random.seed, pos = 1) # because set used set.seed()
  }


  # assemble IDX
  BOOT.idx <- vector("list", length = ngroups)
  for (g in 1:ngroups) {
    # FIXME: handle failed runs
    BOOT.idx[[g]] <- do.call("rbind", lapply(res, "[[", g))
  }

  # merge groups
  if (merge.groups) {
    out <- do.call("cbind", BOOT.idx)
  } else {
    out <- BOOT.idx
  }

  # NOTE: the order of the indices is different from the boot package!
  # we fill in the matrix 'row-wise' (1 row = sample(N, replace = TRUE)),
  # while boot fills in the matrix 'column-wise'
  # this also explains why we get different results with return.boot = TRUE
  # despite using the same iseed

  # return frequencies instead?
  if (return.freq && merge.groups) {
    out <- t(apply(out, 1L, tabulate, ncol(out)))
  }

  out
}


# This code is written by YR (using lavaan components), but based on
# research code written by Mariska Barendse (Groningen/Amsterdam, NL)
#
# September 2013
#
# Three fit indices for the PML estimator (if all categorical, no exo)
# - Cp(max)
# - CF
# - CM

# FIXME: how to handle multiple groups??

# Mariska Barendse Cp statistic
# lav_tables_fit_Cp <- function(object, alpha = 0.05) {
#
#    out <- lavTablesFit(object, statistic = "G2", p.value = TRUE)
#
#    # Bonferonni adjusted p-value
#    ntests <- length(out$lhs)
#    out$alpha.adj <- alpha / ntests
#    #out$pval <- pchisq(out$G2, df=out$df, lower.tail = FALSE)
#
#    # remove G2.h0.pval
#    #out$G2.h0.pval <- NULL
#
#    out
# }

lavTablesFitCp <- function(object, alpha = 0.05) {
  lavdata <- object@Data

  if (!any(lavdata@ov$type == "ordered")) {
    return(list(
      G2 = as.numeric(NA), df = as.numeric(NA),
      p.value = as.numeric(NA), p.value.Bonferroni = as.numeric(NA)
    ))
  }

  TF <- lavTables(object,
    dimension = 2L, type = "table",
    statistic = "G2", p.value = TRUE
  )

  # Bonferonni adjusted p-value
  ntests <- length(TF$lhs)
  TF$alpha.adj <- alpha / ntests

  out <- subset(TF, TF$G2.pval < TF$alpha.adj)

  # find largest G2
  max.idx <- which(TF$G2 == max(TF$G2))

  extra <- list(
    G2 = unname(TF$G2[max.idx]), df = unname(TF$df[max.idx]),
    lhs = TF$lhs[max.idx],
    rhs = TF$rhs[max.idx],
    group = TF$group[max.idx],
    p.value = unname(TF$G2.pval[max.idx]),
    ntests = ntests,
    p.value.Bonferroni = unname(TF$G2.pval[max.idx] * length(TF$lhs))
  )

  attr(out, "CpMax") <- extra

  class(out) <- c("lavaan.tables.fit.Cp", "lavaan.data.frame", "data.frame")

  out
}

lav_tables_fit_cp_print <- function(x, ...) {
  cat("CP-values that are significant at a Bonferroni adjusted level of significance\n")
  tmp <- x
  class(tmp) <- c("lavaan.data.frame", "data.frame")
  print(tmp)
}

# Mariska Barendse CF statistic
lavTablesFitCf <- function(object) {
  # check object class
  if (!inherits(object, "lavaan")) {
    lav_msg_stop(gettext("object must be an object of class lavaan"))
  }
  lavdata <- object@Data
  lavpta <- object@pta
  lavmodel <- object@Model
  lavcache <- object@Cache
  implied <- object@implied

  CF.group <- rep(as.numeric(NA), lavdata@ngroups)
  DF.group <- rep(as.numeric(NA), lavdata@ngroups)

  # check if all ordered
  if (!any(lavdata@ov$type == "ordered")) {
    CF <- as.numeric(NA)
    attr(CF, "CF.group") <- CF.group
    attr(CF, "DF.group") <- DF.group
    return(CF)
  }

  # ord var in this group
  ov.ord <- unique(unlist(lavpta$vnames$ov.ord))
  ov.idx <- which(ov.ord %in% lavdata@ov$name)
  ov.nlev <- lavdata@ov$nlev[ov.idx]

  Sigma.hat <- if (lavmodel@conditional.x) implied$res.cov else implied$cov
  TH <- if (lavmodel@conditional.x) implied$res.th else implied$th
  DF <- prod(ov.nlev) - object@optim$npar - 1L

  for (g in seq_len(lavdata@ngroups)) {
    F.group <- lav_model_objective_fml(
      Sigma.hat = Sigma.hat[[g]],
      TH = TH[[g]],
      th.idx = lavmodel@th.idx[[g]],
      num.idx = lavmodel@num.idx[[g]],
      X = lavdata@X[[g]],
      lavcache = lavcache[[g]]
    )
    CF.group[g] <- 2 * lavdata@nobs[[g]] * F.group
  }

  # check for negative values
  CF.group[CF.group < 0] <- 0.0

  # global test statistic
  CF <- sum(CF.group)

  attr(CF, "CF.group") <- CF.group
  attr(CF, "DF") <- DF
  attr(CF, "rpat.observed") <- sapply(lavdata@Rp, "[[", "npatterns")
  attr(CF, "rpat.total") <- sapply(lavdata@Rp, "[[", "total.patterns")
  attr(CF, "rpat.empty") <- sapply(lavdata@Rp, "[[", "empty.patterns")

  class(CF) <- c("lavaan.tables.fit.Cf", "numeric")

  CF
}

lav_tables_fit_cf_print <- function(x, ...) {
  cat("Total response patterns: ", attr(x, "rpat.total"), "\n")
  cat("Observed response patterns: ", attr(x, "rpat.observed"), "\n")
  cat("Empty response patterns: ", attr(x, "rpat.empty"), "\n")
  cat("Cf results may be biased because of large numbers of empty cells in the multivariate contingency table\n")
  cat("Cf-value, overall:\n")
  CF <- unclass(x)
  attributes(CF) <- NULL
  print(CF)
  CF.group <- attr(x, "CF.group")
  if (length(CF.group) > 1L) {
    cat("Cf-value, per group:\n")
    print(CF.group)
  }
  cat("Degrees of freedom\n")
  print(attr(x, "DF"))
}

lavTablesFitCm <- function(object) {
  lavdata <- object@Data
  lavoptions <- object@Options

  CF.h0 <- lavTablesFitCf(object)

  # fit unrestricted model
  h1 <- lav_object_cor(lavdata,
    estimator = lavoptions$estimator,
    se = "none", test = "none", output = "lavaan"
  )
  CF.h1 <- lavTablesFitCf(h1)

  CF.h0.group <- attr(CF.h0, "CF.group")
  CF.h1.group <- attr(CF.h1, "CF.group")
  DF.h0 <- attr(CF.h0, "DF")
  DF.h1 <- attr(CF.h1, "DF")

  attributes(CF.h0) <- NULL
  attributes(CF.h1) <- NULL

  CM <- CF.h0 - CF.h1
  attr(CM, "CM.group") <- CF.h0.group - CF.h1.group
  attr(CM, "DF") <- DF.h0 - DF.h1

  class(CM) <- c("lavaan.tables.fit.Cm", "numeric")

  CM
}


lav_tables_fit_cm_print <- function(x, ...) {
  # cat("The percentage of empty cells\n") #weet niet goed want FML werkt niet
  # cat("CM results may be a little biased because of large numbers of empty cells in the multivariate contingency table\n")
  cat("Cm-value, overall:\n")
  CM <- unclass(x)
  attributes(CM) <- NULL
  print(CM)
  CM.group <- attr(x, "CM.group")
  if (length(CM.group) > 1L) {
    cat("Cm-value, per group:\n")
    print(CM.group)
  }
  cat("Degrees of freedom:\n")
  print(attr(x, "DF"))
}

# lav_start.R: provide starting values for model parameters
#
# YR 30/11/2010: initial version
# YR 08/06/2011: add fabin3 start values for factor loadings
# YR 14 Jan 2014: moved to lav_start.R

# fill in the 'ustart' column in a User data.frame with reasonable
# starting values, using the sample data

lav_start <- function(start.method = "default",
                      lavpartable = NULL,
                      lavsamplestats = NULL,
                      lavh1 = NULL, # fixme: only use lavh1?
                      model.type = "sem",
                      reflect = FALSE, # rotation only
					            samplestats.flag = TRUE,
                      order.lv.by = "none" # rotation only
					            ) {
  # check arguments
  stopifnot(is.list(lavpartable))

  # categorical?
  categorical <- any(lavpartable$op == "|")

  # correlation structure?
  correlation <- any(lavpartable$op == "~*~")

  # composites?
  composites <- any(lavpartable$op == "<~")

  # conditional.x?
  conditional.x <- any(lavpartable$exo == 1L &
    lavpartable$op %in% c("~", "<~"))
  # ord.names <- unique(lavpartable$lhs[ lavpartable$op == "|" ])

  # nlevels?
  nlevels <- lav_partable_nlevels(lavpartable)

  # reflect/order.lv.by
  if (is.null(reflect)) {
    reflect <- FALSE
  }
  if (is.null(order.lv.by)) {
    order.lv.by <- "index"
  }

  # check start.method
  #if (mimic == "lavaan") {
  start.initial <- "lavaan"
  #} else if (mimic == "Mplus") {
  #  start.initial <- "mplus"
  #} else {
  #  # FIXME: use LISREL/EQS/AMOS/.... schemes
  #  start.initial <- "lavaan"
  #}

  # start.method
  start.user <- NULL
  if (is.character(start.method)) {
    start.method.lc <- tolower(start.method)
	if (start.method.lc != "simple" && !samplestats.flag) {
	    start.method.lc <- start.method <- "simple"
    }
    if (start.method.lc == "default") {
      # nothing to do
    } else if (start.method == "simple") {
      start <- numeric(length(lavpartable$ustart))
      # if(categorical || correlation) {
      start[which(lavpartable$op == "=~")] <- 0.7
      start[which(lavpartable$op == "<~")] <- 1
      # } else {
      #    start[ which(lavpartable$op == "=~") ] <- 1.0
      # }
      start[which(lavpartable$op == "~*~")] <- 1.0
      ov.names.ord <- lav_partable_vnames(lavpartable, "ov.ord")
      var.idx <- which(lavpartable$op == "~~" &
        lavpartable$lhs == lavpartable$rhs &
        !(lavpartable$lhs %in% ov.names.ord))
      start[var.idx] <- 1.0
      user.idx <- which(!is.na(lavpartable$ustart))
      start[user.idx] <- lavpartable$ustart[user.idx]
      return(start) # assuming fixed.x = FALSE!
    } else if (start.method == "est") {
      return(lavpartable$est)
    } else if (start.method.lc %in% c("simple", "lavaan")) {
      start.initial <- start.method.lc
    } else {
     lav_msg_stop(gettext("unknown value for start argument"))
    }
  } else if (is.list(start.method)) {
    start.user <- start.method
  } else if (is.numeric(start.method)) {
    nx.free <- sum(lavpartable$free > 0L)
    if (length(start.method) != nx.free) {
     lav_msg_stop(gettextf(
       "start argument contains %1$s elements; but parameter table
       expects %2$s free parameters.", length(start.method), nx.free))
    }
    lavpartable$ustart[lavpartable$free > 0L] <- start.method
  } else if (inherits(start.method, "lavaan")) {
    start.user <- parTable(start.method)
  }

  # check model list elements, if provided
  if (!is.null(start.user)) {
    if (is.null(start.user$lhs) ||
      is.null(start.user$op) ||
      is.null(start.user$rhs)) {
     lav_msg_stop(gettext(
       "problem with start argument: model list does not contain
       all elements: lhs/op/rhs"))
    }
    if (!is.null(start.user$est)) {
      # excellent, we got an est column; nothing to do
    } else if (!is.null(start.user$start)) {
      # no est column, but we use the start column
      start.user$est <- start.user$start
    } else if (!is.null(start.user$ustart)) {
      # no ideal, but better than nothing
      start.user$est <- start.user$ustart
    } else {
     lav_msg_stop(gettext(
       "problem with start argument: could not find est/start column
       in model list"))
    }
  }


  # global settings
  # 0. everyting is zero
  start <- numeric(length(lavpartable$ustart))

  # 1. =~ factor loadings:
  if (categorical || correlation) {
    # if std.lv=TRUE, 0.8 is too large
    start[which(lavpartable$op == "=~")] <- 0.7
  } else {
    start[which(lavpartable$op == "=~")] <- 1.0
  }

  # 2. (residual) lv variances for latent variables
  lv.names <- lav_partable_vnames(lavpartable, "lv") # all groups
  lv.var.idx <- which(lavpartable$op == "~~" &
    lavpartable$lhs %in% lv.names &
    lavpartable$lhs == lavpartable$rhs)
  start[lv.var.idx] <- 0.05
  # start[lv.var.idx] <- 0.5 # new in 0.6-2? (for optim.parscale = "stand")

  # 3. latent response scales (if any)
  delta.idx <- which(lavpartable$op == "~*~")
  start[delta.idx] <- 1.0


  # group-specific settings
  ngroups <- lav_partable_ngroups(lavpartable)

  # for now, if no group column, add one (again), until we rewrite
  # this function to handle block/group hybrid settings
  if (is.null(lavpartable$group) && ngroups == 1L) {
    lavpartable$group <- rep(1L, length(lavpartable$lhs))
    lavpartable$group[lavpartable$block == 0L] <- 0L
  }

  # group values
  group.values <- lav_partable_group_values(lavpartable)

  for (g in 1:ngroups) {

    # info from user model for this group
    if (conditional.x) {
      ov.names <- lav_partable_vnames(lavpartable, "ov.nox", group = group.values[g])
    } else {
      ov.names <- lav_partable_vnames(lavpartable, "ov", group = group.values[g])
    }
    if (categorical) {
      ov.names.num <- lav_partable_vnames(lavpartable, "ov.num", group = group.values[g])
      ov.names.ord <- lav_partable_vnames(lavpartable, "ov.ord", group = group.values[g])
    } else {
      ov.names.num <- ov.names
    }
    lv.names <- lav_partable_vnames(lavpartable, "lv", group = group.values[g])
    lv.names.efa <- lav_partable_vnames(lavpartable, "lv.efa", group = group.values[g])
    ov.names.x <- lav_partable_vnames(lavpartable, "ov.x", group = group.values[g])
    ov.ind.c <- lav_partable_vnames(lavpartable, "ov.cind", group = group.values[g])
    lv.names.c <- lav_partable_vnames(lavpartable, "lv.composite", group = group.values[g])

    # just for the nlevels >1 case
    ov.names <- unique(unlist(ov.names))
    ov.names.num <- unique(unlist(ov.names.num))
    lv.names <- unique(unlist(lv.names))
    lv.names.efa <- unique(unlist(lv.names.efa))
    ov.names.x <- unique(unlist(ov.names.x))
    ov.ind.c <- unique(unlist(ov.ind.c))
    lv.names.c <- unique(unlist(lv.names.c))
    lv.names.noc <- lv.names[!lv.names %in% lv.names.c]

    # residual ov variances (including exo/ind, to be overriden)
    ov.var.idx <- which(lavpartable$group == group.values[g] &
      lavpartable$op == "~~" &
      lavpartable$lhs %in% ov.names.num &
      lavpartable$lhs == lavpartable$rhs)
    sample.var.idx <- match(lavpartable$lhs[ov.var.idx], ov.names)
    if (model.type == "unrestricted") {
	  # this does not work if conditional.x = TRUE...
      if (!is.null(lavh1$implied$cov[[g]])) {
        h1.cov <- lavh1$implied$cov[[g]]
      } else if (!is.null(lavsamplestats@missing.h1[[g]])) {
        h1.cov <- lavsamplestats@missing.h1[[g]]$sigma
      } else {
        h1.cov <- lavsamplestats@cov[[g]]
      }
      start[ov.var.idx] <- diag(h1.cov)[sample.var.idx]
    } else {
      #if (start.initial == "mplus") {
      #  if (conditional.x && nlevels == 1L) {
      #    start[ov.var.idx] <-
      #      (1.0 - 0.50) * lavsamplestats@res.var[[1L]][sample.var.idx]
      #  } else {
      #    start[ov.var.idx] <-
      #      (1.0 - 0.50) * lavsamplestats@var[[1L]][sample.var.idx]
      #  }
      #} else {
        if (conditional.x && nlevels == 1L) {
          start[ov.var.idx] <-
            (1.0 - 0.50) * diag(lavsamplestats@res.cov[[g]])[sample.var.idx]
        } else {
          start[ov.var.idx] <-
            (1.0 - 0.50) * diag(lavsamplestats@cov[[g]])[sample.var.idx]
        }
      #}
      # composite indicators: fill in total variances
      if (composites) {
        start[ov.var.idx] <- diag(lavsamplestats@cov[[g]])[sample.var.idx]
      }
    }

    # 1-fac measurement models: loadings, psi, theta
    if (start.initial %in% c("lavaan") &&
      model.type %in% c("sem", "cfa")) {
      # fabin3 estimator (2sls) of Hagglund (1982) per factor
      for (f in lv.names.noc) {
        # not for efa factors
        if (f %in% lv.names.efa) {
          next
        }
        lambda.idx <- which(lavpartable$lhs == f &
          lavpartable$op == "=~" &
          lavpartable$group == group.values[g])
        # standardized?
        std.lv <- FALSE
        var.f.idx <- which(lavpartable$lhs == f &
          lavpartable$op == "~~" &
          lavpartable$group == group.values[g] &
          lavpartable$rhs == f)
        if (length(var.f.idx) > 0L &&
          all(lavpartable$free[var.f.idx] == 0) &&
          all(lavpartable$ustart[var.f.idx] == 1)) {
          std.lv <- TRUE
        }

        # no second order
        if (any(lavpartable$rhs[lambda.idx] %in% lv.names)) next

        # get observed indicators for this latent variable
        ov.idx <- match(lavpartable$rhs[lambda.idx], ov.names)
        if (length(ov.idx) > 0L && !any(is.na(ov.idx))) {
          if (lavsamplestats@missing.flag && nlevels == 1L) {
            if (!is.null(lavh1$implied$cov[[g]])) {
              h1.cov <- lavh1$implied$cov[[g]]
            } else {
              h1.cov <- lavsamplestats@missing.h1[[g]]$sigma
            }
            COV <- h1.cov[ov.idx, ov.idx, drop = FALSE]
          } else {
            if (conditional.x && nlevels == 1L) {
              COV <- lavsamplestats@res.cov[[g]][ov.idx,
                ov.idx,
                drop = FALSE
              ]
            } else {
              COV <- lavsamplestats@cov[[g]][ov.idx,
                ov.idx,
                drop = FALSE
              ]
            }
          }

          # fabin for 1-factor
          fabin <- lav_cfa_1fac_fabin(COV,
            std.lv = std.lv,
            lambda.only = TRUE,
            method = "fabin3"
          )

          # factor loadings
          tmp <- fabin$lambda
          tmp[!is.finite(tmp)] <- 1.0 # just in case (eg 0/0)

          # check for negative triad if nvar=3L (new in 0.6-8)
          if (!is.null(fabin$neg.triad) && fabin$neg.triad) {
            if (std.lv) {
              tmp <- rep(0.7, length(tmp))
            } else {
              tmp <- rep(1.0, length(tmp))
            }
          }

          # check for negative marker
          if (!std.lv && !is.na(lavpartable$ustart[lambda.idx[1]]) &&
              lavpartable$ustart[lambda.idx[1]] < 0) {
            tmp <- -1 * tmp
          }

          start[lambda.idx] <- tmp

          # factor variance
          # if(!std.lv) {
          #    start[var.f.idx] <- fabin$psi
          #    # if residual var, make smaller
          #    y.idx <- which(lavpartable$lhs == f &
          #                   lavpartable$group == group.values[g] &
          #                   lavpartable$op == "~")
          #    if(length(y.idx) > 0L) {
          #        # how much explained variance do we expect?
          #        # we take 0.50
          #        start[var.f.idx] <- 0.5 * start[var.f.idx]
          #    }
          #    # no negative variances (we get these if we have an
          #    # inconsistent triad (eg, covariance signs are +,+,-)
          #    if(start[var.f.idx] < 0) {
          #        start[var.f.idx] <- 0.05
          #    }
          # }

          # NOTE: fabin (sometimes) gives residual variances
          # that are larger than the original variances...

          # residual variances -- order?
          # res.idx <- which(lavpartable$lhs %in% ov.names[ov.idx] &
          #                 lavpartable$op == "~~" &
          #                 lavpartable$group == group.values[g] &
          #                 lavpartable$rhs == lavpartable$lhs)
          # start[res.idx] <- fabin$theta

          # negative variances?
          # neg.idx <- which(start[res.idx] < 0)
          # if(length(neg.idx) > 0L) {
          #    start[res.idx][neg.idx] <- 0.05
          # }
        }
      } # fabin3

      # efa?
      nefa <- lav_partable_nefa(lavpartable)
      if (nefa > 0L) {
        efa.values <- lav_partable_efa_values(lavpartable)

        for (set in seq_len(nefa)) {
          # determine ov idx for this set
          ov.efa <-
            unique(lavpartable$rhs[lavpartable$op == "=~" &
              lavpartable$block == g &
              lavpartable$efa == efa.values[set]])
          lv.efa <-
            unique(lavpartable$lhs[lavpartable$op == "=~" &
              lavpartable$block == g &
              lavpartable$efa == efa.values[set]])
          lambda.idx <- which(lavpartable$lhs %in% lv.efa &
            lavpartable$op == "=~" &
            lavpartable$group == group.values[g])

          theta.idx <- which(lavpartable$lhs %in% ov.efa &
            lavpartable$op == "~~" &
            lavpartable$lhs == lavpartable$rhs &
            lavpartable$group == group.values[g])

          # get observed indicators for these EFA lv variables
          ov.idx <- match(
            unique(lavpartable$rhs[lambda.idx]),
            ov.names
          )

          if (length(ov.idx) > 0L && !any(is.na(ov.idx))) {
            if (lavsamplestats@missing.flag && nlevels == 1L) {
              if (!is.null(lavh1$implied$cov[[g]])) {
                h1.cov <- lavh1$implied$cov[[g]]
              } else {
                h1.cov <- lavsamplestats@missing.h1[[g]]$sigma
              }
              COV <- h1.cov[ov.idx, ov.idx, drop = FALSE]
            } else {
              if (conditional.x) {
                COV <- lavsamplestats@res.cov[[g]][ov.idx,
                  ov.idx,
                  drop = FALSE
                ]
              } else {
                COV <- lavsamplestats@cov[[g]][ov.idx,
                  ov.idx,
                  drop = FALSE
                ]
              }
            }

            # EFA solution with zero upper-right corner
            EFA <- lav_efa_extraction(
              S = COV,
              nfactors = length(lv.efa),
              method = "ML",
              order.lv.by = order.lv.by,
              # order.lv.by = "none",
              # reflect = reflect,
              reflect = FALSE,
              corner = TRUE
            )

            # factor loadings
            tmp <- as.numeric(EFA$LAMBDA)
            tmp[!is.finite(tmp)] <- 1.0 # just in case (eg 0/0)
            start[lambda.idx] <- tmp

            # residual variances
            tmp <- diag(EFA$THETA)
            tmp[!is.finite(tmp)] <- 1.0 # just in case
            start[theta.idx] <- tmp
          }
        } # set
      } # efa
    } # factor loadings

    if (model.type == "unrestricted") {
      # fill in 'covariances' from lavsamplestats
      cov.idx <- which(lavpartable$group == group.values[g] &
        lavpartable$op == "~~" &
        lavpartable$lhs != lavpartable$rhs)
      lhs.idx <- match(lavpartable$lhs[cov.idx], ov.names)
      rhs.idx <- match(lavpartable$rhs[cov.idx], ov.names)
      if (!is.null(lavh1$implied$cov[[g]])) {
        h1.cov <- lavh1$implied$cov[[g]]
      } else if (!is.null(lavsamplestats@missing.h1[[g]])) {
        h1.cov <- lavsamplestats@missing.h1[[g]]$sigma
      } else {
        h1.cov <- lavsamplestats@cov[[g]]
      }
      start[cov.idx] <- h1.cov[cbind(lhs.idx, rhs.idx)]
    }

    # composites
    if (composites) {
      std.lv <- FALSE
      var.f.idx <- which(lavpartable$lhs %in% lv.names.c &
        lavpartable$op == "~~" &
        lavpartable$group == group.values[g] &
        lavpartable$rhs %in% lv.names.c)
      if (length(var.f.idx) > 0L &&
        all(lavpartable$free[var.f.idx] == 0) &&
        !all(is.na(lavpartable$ustart[var.f.idx])) &&
        all(lavpartable$ustart[var.f.idx] == 1)) {
        std.lv <- TRUE
      }

      # weights
      cidx <- which(lavpartable$group == group.values[g] &
        lavpartable$op == "<~")
      if (std.lv) {
        start[cidx] <- 0.10
      } else {
        start[cidx] <- 1
      }

      # fill in 'covariances' from lavsamplestats
      cov.idx <- which(lavpartable$group == group.values[g] &
        lavpartable$op == "~~" &
        lavpartable$rhs %in% ov.ind.c &
        lavpartable$lhs != lavpartable$rhs)
      lhs.idx <- match(lavpartable$lhs[cov.idx], ov.names)
      rhs.idx <- match(lavpartable$rhs[cov.idx], ov.names)
      if (!is.null(lavh1$implied$cov[[g]])) {
        h1.cov <- lavh1$implied$cov[[g]]
      } else if (!is.null(lavsamplestats@missing.h1[[g]])) {
        h1.cov <- lavsamplestats@missing.h1[[g]]$sigma
      } else {
        h1.cov <- lavsamplestats@cov[[g]]
      }
      start[cov.idx] <- h1.cov[cbind(lhs.idx, rhs.idx)]
    }

    # variances of ordinal variables - set to 1.0
    if (categorical) {
      ov.var.ord.idx <- which(lavpartable$group == group.values[g] &
        lavpartable$op == "~~" &
        lavpartable$lhs %in% ov.names.ord &
        lavpartable$lhs == lavpartable$rhs)
      start[ov.var.ord.idx] <- 1.0
    }

    # 3g) intercepts/means
    ov.int.idx <- which(lavpartable$group == group.values[g] &
      lavpartable$op == "~1" &
      lavpartable$lhs %in% ov.names)
    sample.int.idx <- match(lavpartable$lhs[ov.int.idx], ov.names)
    if (lavsamplestats@missing.flag && nlevels == 1L) {
      if (!is.null(lavh1$implied$mean[[g]])) {
        h1.mean <- lavh1$implied$mean[[g]]
      } else if (!is.null(lavsamplestats@missing.h1[[g]])) {
        h1.mean <- lavsamplestats@missing.h1[[g]]$mu
      } else {
        h1.mean <- lavsamplestats@mean[[g]]
      }
      start[ov.int.idx] <- h1.mean[sample.int.idx]
    } else {
      if (conditional.x && nlevels == 1L) {
        start[ov.int.idx] <- lavsamplestats@res.int[[g]][sample.int.idx]
      } else {
        start[ov.int.idx] <- lavsamplestats@mean[[g]][sample.int.idx]
      }
    }

    # TODo: if marker.int.zero = TRUE, set lv means to marker means,
    #       and the non-marker means to
    #       lavsamplestats@mean[[g]] - LAMBDA %*% ALPHA
    #       where ALPHA = means of the markers

    # 4g) thresholds
    th.idx <- which(lavpartable$group == group.values[g] &
                      lavpartable$op == "|")
    if (length(th.idx) > 0L) {
      th.names.lavpartable <- paste(lavpartable$lhs[th.idx], "|",
        lavpartable$rhs[th.idx],
        sep = ""
      )
      th.names.sample <-
        lavsamplestats@th.names[[g]][lavsamplestats@th.idx[[g]] > 0L]
      # th.names.sample should identical to
      # lav_partable_vnames(lavpartable, "th", group = group.values[g])
      if (conditional.x && nlevels == 1L) {
        th.values <-
          lavsamplestats@res.th[[g]][lavsamplestats@th.idx[[g]] > 0L]
      } else {
        th.values <-
          lavsamplestats@th[[g]][lavsamplestats@th.idx[[g]] > 0L]
      }
      start[th.idx] <- th.values[match(
        th.names.lavpartable,
        th.names.sample
      )]
    }

    # 5g) exogenous `fixed.x' covariates
    if (length(ov.names.x) > 0) {
      exo.idx <- which(lavpartable$group == group.values[g] &
        lavpartable$op == "~~" &
        lavpartable$lhs %in% ov.names.x &
        lavpartable$rhs %in% ov.names.x)
      if (!conditional.x) {
        row.idx <- match(lavpartable$lhs[exo.idx], ov.names)
        col.idx <- match(lavpartable$rhs[exo.idx], ov.names)
        if (lavsamplestats@missing.flag && nlevels == 1L) {
          if (!is.null(lavh1$implied$cov[[g]])) {
            h1.cov <- lavh1$implied$cov[[g]]
          } else if (!is.null(lavsamplestats@missing.h1[[g]])) {
            h1.cov <- lavsamplestats@missing.h1[[g]]$sigma
          } else {
            h1.cov <- lavsamplestats@cov[[g]]
          }
          start[exo.idx] <- h1.cov[cbind(row.idx, col.idx)]
          # using slightly smaller starting values for free
          # variance/covariances (fixed.x = FALSE);
          # this somehow avoids false convergence in saturated models
          nobs <- lavsamplestats@nobs[[g]]
          this.idx <- which(seq_len(length(lavpartable$free)) %in% exo.idx &
                              lavpartable$free > 0L)
          start[this.idx] <- start[this.idx] * (nobs - 1) / nobs
        } else {
          start[exo.idx] <- lavsamplestats@cov[[g]][cbind(row.idx, col.idx)]
        }
      } else {
        # cov.x
        row.idx <- match(lavpartable$lhs[exo.idx], ov.names.x)
        col.idx <- match(lavpartable$rhs[exo.idx], ov.names.x)
        start[exo.idx] <- lavsamplestats@cov.x[[g]][cbind(
          row.idx,
          col.idx
        )]
        # mean.x
        exo.int.idx <- which(lavpartable$group == group.values[g] &
          lavpartable$op == "~1" &
          lavpartable$lhs %in% ov.names.x)
        int.idx <- match(lavpartable$lhs[exo.int.idx], ov.names.x)
        start[exo.int.idx] <- lavsamplestats@mean.x[[g]][int.idx]
      }
    }

    # 6b. exogenous lv variances if single indicator -- new in 0.5-21
    lv.x <- lav_partable_vnames(lavpartable, "lv.x", group = group.values[g])
    # FIXME: also for multilevel?
    lv.x <- unique(unlist(lv.x))
    if (length(lv.x) > 0L) {
      for (ll in lv.x) {
        ind.idx <- which(lavpartable$op == "=~" &
          lavpartable$lhs == ll &
          lavpartable$group == group.values[g])
        if (length(ind.idx) == 1L) {
          single.ind <- lavpartable$rhs[ind.idx]
          single.fvar.idx <- which(lavpartable$op == "~~" &
            lavpartable$lhs == ll &
            lavpartable$rhs == ll &
            lavpartable$group == group.values[g])
          single.var.idx <- which(lavpartable$op == "~~" &
            lavpartable$lhs == single.ind &
            lavpartable$rhs == single.ind &
            lavpartable$group == group.values[g])
          # user-defined residual variance
          # fixme: we take the first, in case we have multiple matches
          # (eg nlevels)
          single.var <- lavpartable$ustart[single.var.idx[1]]
          if (is.na(single.var)) {
            single.var <- 1
          }
          ov.idx <- match(single.ind, ov.names)
          if (conditional.x && nlevels == 1L) {
            ov.var <- diag(lavsamplestats@res.cov[[g]])[ov.idx]
          } else {
            ov.var <- diag(lavsamplestats@cov[[g]])[ov.idx]
          }
          # take (1 - (rvar/ov.var) * ov.var
          tmp <- (1 - (single.var / ov.var)) * ov.var
          # just in case
          if (is.na(tmp) || tmp < 0.05) {
            tmp <- 0.05
          }
          start[single.fvar.idx] <- tmp
        }
      }
    }

    # 7g) regressions "~" # new in 0.6-10
    if (length(lv.names) == 0L && nlevels == 1L && !conditional.x) {
      # observed only
      reg.idx <- which(lavpartable$group == group.values[g] &
        lavpartable$op == "~")
      if (length(reg.idx) > 0L) {
        eqs.y <- unique(lavpartable$lhs[reg.idx])
        ny <- length(eqs.y)
        for (i in seq_len(ny)) {
          y.name <- eqs.y[i]
          start.idx <- which(lavpartable$group == group.values[g] &
            lavpartable$op == "~" &
            lavpartable$lhs == y.name)
          x.names <- lavpartable$rhs[start.idx]
          COV <- lavsamplestats@cov[[g]]
          y.idx <- match(y.name, ov.names)
          x.idx <- match(x.names, ov.names)
          S.xx <- COV[x.idx, x.idx, drop = FALSE]
          S.xy <- COV[x.idx, y.idx, drop = FALSE]
          # regression coefficient(s)
          beta.i <- try(solve(S.xx, S.xy), silent = TRUE)
          if (inherits(beta.i, "try-error")) {
            start[start.idx] <- beta.i <- rep(0, length(start.idx))
          } else {
            start[start.idx] <- drop(beta.i)
          }
          # residual variance
          res.idx <- which(lavpartable$group == group.values[g] &
            lavpartable$op == "~~" &
            lavpartable$lhs == y.name &
            lavpartable$rhs == y.name)
          res.val <- COV[y.idx, y.idx] - drop(crossprod(beta.i, S.xy))
          if (res.val > 0.001 * COV[y.idx, y.idx] &&
            res.val < 0.999 * COV[y.idx, y.idx]) {
            start[res.idx] <- res.val
          } else {
            # do nothing (keep what we have)
          }
          # intercept
          int.idx <- which(lavpartable$group == group.values[g] &
            lavpartable$op == "~1" &
            lavpartable$lhs == y.name)
          if (length(int.idx) > 0L) {
            MEAN <- lavsamplestats@mean[[g]]
            Ybar <- MEAN[y.idx]
            Xbar <- MEAN[x.idx]
            int.val <- Ybar - drop(crossprod(beta.i, Xbar))
            if (is.finite(int.val)) {
              start[int.idx] <- int.val
            }
          }
        }
      }
    }

    #  # 8 latent variances (new in 0.6-2)
    #  lv.names.y <- lav_partable_vnames(lavpartable, "lv.y", group = group.values[g])
    #  lv.names.x <- lav_partable_vnames(lavpartable, "lv.x", group = group.values[g])
    #  # multilevel? take first level only
    #  if(is.list(lv.names.y)) {
    #      lv.names.y <- unlist(lv.names.y) # for now
    #  }
    #  if(is.list(lv.names.x)) {
    #      lv.names.x <- unlist(lv.names.x) # for now
    #  }
    #  lv.names.xy <- unique(c(lv.names.x, lv.names.y))


    #  if(length(lv.names.xy) > 0L) {
    #      free.var.idx <- which(lavpartable$op == "~~" &
    #                            lavpartable$lhs %in% lv.names.xy &
    #                            lavpartable$rhs == lavpartable$lhs &
    #                            lavpartable$group == group.values[g])
    #      if(length(free.var.idx) > 0L) {
    #          this.lv.names <- lavpartable$lhs[free.var.idx]
    #          for(v in seq_len(length(free.var.idx))) {
    #              # single marker item?
    #              ind.idx <- which(lavpartable$op == "=~" &
    #                               lavpartable$lhs %in% this.lv.names[v] &
    #                               #lavpartable$rhs %in% ov.names.num &
    #                               lavpartable$free == 0L &
    #                               lavpartable$group == group.values[g])
    #              if(length(ind.idx) == 0) {
    #                  next
    #              } else if(length(ind.idx) > 1L) {
    #                  # FIXME! perhaps a random effect? do something clever
    #                  next
    #              } else if(length(ind.idx) == 1L) {
    #                  marker.ind <- lavpartable$rhs[ind.idx]
    #                  ov.idx <- match(marker.ind, ov.names)
    #                  if(conditional.x) {
    #                      ov.var <- diag(lavsamplestats@res.cov[[g]])[ov.idx]
    #                  } else {
    #                      ov.var <- diag(lavsamplestats@cov[[g]])[ov.idx]
    #                  }
    #
    #                  # exogenous? assume rel = 0.50
    #                  lambda <- lavpartable$ustart[ind.idx]
    #                  tmp <- (0.50 * ov.var)/lambda^2
    #                  if(this.lv.names[v] %in% lv.names.y) {
    #                      # endogenous, assume R2 = 0.2
    #                      tmp <- 0.8 * tmp
    #                  }
    #                  # within variance?
    #                  if(nlevels > 1L &&
    #                     lavpartable$level[ free.var.idx[v] ] == 1L) {
    #                      tmp <- tmp * 0.75
    #                  }
    #                  # between variance?
    #                  if(nlevels > 1L &&
    #                     lavpartable$level[ free.var.idx[v] ] > 1L) {
    #                      tmp <- tmp * 0.25
    #                  }
    #                  # just in case
    #                  if(is.na(tmp) || tmp < 0.05) {
    #                      tmp <- 0.05
    #                  }
    #                  start[ free.var.idx[v] ] <- tmp
    #              }
    #          } # v
    #      } # free.var.idx
    #  } # lv var

    # nlevels > 1L
    if (nlevels > 1L) {
      level.values <- lav_partable_level_values(lavpartable)
      # Note: ov.names.x contains all levels within a group!
      if (length(ov.names.x) > 0) {
        for (l in 1:nlevels) {
          # block number
          block <- (g - 1L) * nlevels + l

          this.block.x <- lav_partable_vnames(lavpartable, "ov.x",
            block = block
          )
          this.block.ov <- lav_partable_vnames(lavpartable, "ov",
            block = block
          )
          if (length(this.block.x) == 0L) {
            next
          }

          # var/cov
          exo.idx <- which(lavpartable$group == group.values[g] &
            lavpartable$level == level.values[l] &
            lavpartable$op == "~~" &
            lavpartable$lhs %in% this.block.x &
            lavpartable$rhs %in% this.block.x)

          if (is.null(lavh1$implied$cov[[1]])) {
            row.idx <- match(lavpartable$lhs[exo.idx], ov.names)
            col.idx <- match(lavpartable$rhs[exo.idx], ov.names)
            if (l == 1L) {
              COV <- lavsamplestats@YLp[[g]][[2]]$S.PW.start
            } else {
              COV <- lavsamplestats@YLp[[g]][[l]]$Sigma.B
            }
          } else {
            row.idx <- match(lavpartable$lhs[exo.idx], this.block.ov)
            col.idx <- match(lavpartable$rhs[exo.idx], this.block.ov)
            COV <- lavh1$implied$cov[[block]]
          }
          # make sure starting values for variances are positive
          neg.idx <- which(diag(COV) < 0.001)
          if (length(neg.idx) > 0L) {
            diag(COV)[neg.idx] <- 0.001
          }
          start[exo.idx] <- COV[cbind(row.idx, col.idx)]

          # intercepts
          ov.int.idx <- which(lavpartable$group == group.values[g] &
            lavpartable$level == level.values[l] &
            lavpartable$op == "~1" &
            lavpartable$lhs %in% this.block.x)

          if (is.null(lavh1$implied$mean[[1]])) {
            idx <- match(lavpartable$lhs[ov.int.idx], ov.names)
            if (l == 1L) {
              INT <- lavsamplestats@YLp[[g]][[2]]$Mu.W
            } else {
              INT <- lavsamplestats@YLp[[g]][[l]]$Mu.B.start
            }
          } else {
            idx <- match(lavpartable$lhs[ov.int.idx], this.block.ov)
            INT <- lavh1$implied$mean[[block]]
          }
          start[ov.int.idx] <- INT[idx]

          # new in 0.6-12
          # very special case: conditional.x with a combination of
          # splitted-x and regular-x
          # here, we must:
          # 1) replace var/cov of splitted-x by *residual* varcov
          #    after regressing out regular-x
          # 2) replace means of splitted-x by intercepts
          # 3) fill splitted-x ~ regular-x regression coefficients
          if (conditional.x) {
            if (is.null(lavh1$implied$cov[[l]])) {
             lav_msg_stop(gettext(
               "lavh1 information is needed; please rerun with h1 = TRUE"))
            }
            blocks.within.group <- (g - 1L) * nlevels + seq_len(nlevels)
            OTHER.BLOCK.NAMES <- lav_partable_vnames(lavpartable, "ov",
                                    block = blocks.within.group[-block])
            ov.names.x.block <- this.block.x
            idx <- which(ov.names.x.block %in% OTHER.BLOCK.NAMES)
            if (length(idx) > 0L) {
              ov.names.x.block <- ov.names.x.block[-idx]
            }
            ov.names.x1 <- this.block.x[!this.block.x %in% ov.names.x.block]
            ov.names.x2 <- ov.names.x.block
            nx1 <- length(ov.names.x1) # splitted x
            nx2 <- length(ov.names.x2) # regular  x
            if (nx1 > 0L && nx2 > 0L) {
              # COV
              c1.idx <- match(ov.names.x1, this.block.ov)
              c2.idx <- match(ov.names.x2, this.block.ov)

              COV.Y <- COV[c1.idx, c1.idx, drop = FALSE]
              COV.X <- COV[c2.idx, c2.idx, drop = FALSE]
              COV.YX <- COV[c1.idx, c2.idx, drop = FALSE]
              COV.XY <- COV[c2.idx, c1.idx, drop = FALSE]
              COV.XinvYX <- solve(COV.X, COV.XY)
              RES.COV <- COV.Y - COV.YX %*% COV.XinvYX

              res.cov.idx <- which(lavpartable$group == group.values[g] &
                lavpartable$level == level.values[l] &
                lavpartable$op == "~~" &
                lavpartable$lhs %in% ov.names.x1 &
                lavpartable$rhs %in% ov.names.x1)

              row.idx <- match(lavpartable$lhs[res.cov.idx], ov.names.x1)
              col.idx <- match(lavpartable$rhs[res.cov.idx], ov.names.x1)
              start[res.cov.idx] <- RES.COV[cbind(row.idx, col.idx)]

              # INT
              INT.Y <- INT[c1.idx]
              INT.X <- INT[c2.idx]
              RES.INT <- INT.Y - t(COV.XinvYX) %*% INT.X

              res.int.idx <- which(lavpartable$group == group.values[g] &
                lavpartable$level == level.values[l] &
                lavpartable$op == "~1" &
                lavpartable$lhs %in% ov.names.x1)
              idx <- match(lavpartable$lhs[res.int.idx], ov.names.x1)
              start[res.int.idx] <- RES.INT[idx]

              # REG
              reg.idx <- which(lavpartable$group == group.values[g] &
                lavpartable$level == level.values[l] &
                lavpartable$op == "~" &
                lavpartable$lhs %in% ov.names.x1 &
                lavpartable$rhs %in% ov.names.x2)
              row.idx <- match(lavpartable$lhs[reg.idx], ov.names.x1)
              col.idx <- match(lavpartable$rhs[reg.idx], ov.names.x2)
              start[reg.idx] <- t(COV.XinvYX)[cbind(row.idx, col.idx)]
            } # special case
          } # conditional.x
        } # levels
      } # fixed.x
    } # nlevels > 1L
  } # groups




  # group weights
  group.idx <- which(lavpartable$lhs == "group" &
    lavpartable$op == "%")
  if (length(group.idx) > 0L) {
    ngroups <- length(group.idx)
    # prop <- rep(1/ngroups, ngroups)
    # use last group as reference
    # start[group.idx] <- log(prop/prop[ngroups])

    # poisson version
    start[group.idx] <- log(rep(lavsamplestats@ntotal / ngroups, ngroups))
  }

  # growth models:
  # - compute starting values for mean latent variables
  # - compute starting values for variance latent variables
  if (start.initial %in% c("lavaan") &&
    model.type == "growth") {
    ### DEBUG ONLY
    # lv.var.idx <- which(lavpartable$op == "~~"                &
    #                lavpartable$lhs %in% lv.names &
    #                lavpartable$lhs == lavpartable$rhs)

    ### DEBUG ONLY
    # lv.int.idx <- which(lavpartable$op == "~1"         &
    #                    lavpartable$lhs %in% lv.names)
  }

  # adjust if outside bounds -- new in 0.6-6
  if (!is.null(lavpartable$lower)) {
    bad.idx <- which(start < lavpartable$lower)
    if (length(bad.idx)) {
      start[bad.idx] <- lavpartable$lower[bad.idx]
    }
  }
  if (!is.null(lavpartable$upper)) {
    bad.idx <- which(start > lavpartable$upper)
    if (length(bad.idx)) {
      start[bad.idx] <- lavpartable$upper[bad.idx]
    }
  }


  # override if the model syntax contains explicit starting values (free only)
  # user.idx <- which(!is.na(lavpartable$ustart) &
  #                  lavpartable$user != 7L) # new in 0.6-7, if rotation and
  #                                          # and we change the order of lv's
  user.idx <- which(!is.na(lavpartable$ustart) & lavpartable$free > 0L)
  start[user.idx] <- lavpartable$ustart[user.idx]

  # override if a user list with starting values is provided
  # we only look at the 'est' column for now
  if (!is.null(start.user)) {
    if (is.null(lavpartable$group)) {
      lavpartable$group <- rep(1L, length(lavpartable$lhs))
    }
    if (is.null(start.user$group)) {
      start.user$group <- rep(1L, length(start.user$lhs))
    }

    # FIXME: avoid for loop!!!
    for (i in seq_along(lavpartable$lhs)) {
      # find corresponding parameters
      lhs <- lavpartable$lhs[i]
      op <- lavpartable$op[i]
      rhs <- lavpartable$rhs[i]
      grp <- lavpartable$group[i]

      start.user.idx <- which(start.user$lhs == lhs &
        start.user$op == op &
        start.user$rhs == rhs &
        start.user$group == grp)
      if (length(start.user.idx) == 1L &&
        is.finite(start.user$est[start.user.idx])) {
        start[i] <- start.user$est[start.user.idx]
      }
    }
  }

  # override fixed values with ustart values
  user.idx <- which(!is.na(lavpartable$ustart) & lavpartable$free == 0L)
  start[user.idx] <- lavpartable$ustart[user.idx]

  # new in 0.6-21
  # if any thresholds, make sure they are in increasing order
  # (could be an issue if the first and second were fixed to 0 and 1)
  for (g in 1:ngroups) {
    th.idx <- which(lavpartable$group == group.values[g] &
                    lavpartable$op == "|")
    if (length(th.idx) > 0L) {
      # for every ov.ord, check if t1 < t2 < t3 < ...
      ov.ord <- unique(lavpartable$lhs[th.idx])
      for (oo in ov.ord) {
        this.idx <- which(lavpartable$group == group.values[g] &
                          lavpartable$op == "|" & lavpartable$lhs == oo)
        item.th <- start[this.idx]
        if (length(item.th) > 1L && !all(diff(item.th) > 0)) {
          start[this.idx] <- cumsum(abs(item.th))
        }
      }
    }
  }


  # final check: no NaN or other non-finite values
  bad.idx <- which(!is.finite(start))
  if (length(bad.idx) > 0L) {
    cat("starting values:\n")
    print(start)
     lav_msg_warn(gettext(
       "some starting values are non-finite; replacing them with 0.5;
       please provide better starting values."))
    start[bad.idx] <- 0.5
  }

  if (lav_debug()) {
    cat("lavaan DEBUG: lavaanStart\n")
    print(start)
  }

  start
}

# backwards compatibility
# StartingValues <- lav_start

# sanity check: (user-specified) variances smaller than covariances
# but not for composites, as we have not 'set' their variances yet
lav_start_check_cov <- function(lavpartable = NULL, start = lavpartable$start) {
  nblocks <- lav_partable_nblocks(lavpartable)
  block.values <- lav_partable_block_values(lavpartable)

  for (g in 1:nblocks) {

    lv.names.c <- lav_partable_vnames(lavpartable, "lv.composite", block = g)

    # collect all non-zero covariances
    cov.idx <- which(lavpartable$op == "~~" &
      lavpartable$block == block.values[g] &
      !lavpartable$lhs %in% lv.names.c &
      lavpartable$lhs != lavpartable$rhs &
      !lavpartable$exo &
      start != 0)

    # for each covariance, use corresponding variances to standardize;
    # the end result should not exceed abs(1)
    for (cc in seq_along(cov.idx)) {
      this.cov.idx <- cov.idx[cc]

      # find corresponding variances
      var.lhs <- lavpartable$lhs[this.cov.idx]
      var.rhs <- lavpartable$rhs[this.cov.idx]

      var.lhs.idx <- which(lavpartable$op == "~~" &
        lavpartable$block == block.values[g] &
        lavpartable$lhs == var.lhs &
        lavpartable$lhs == lavpartable$rhs)

      var.rhs.idx <- which(lavpartable$op == "~~" &
        lavpartable$block == block.values[g] &
        lavpartable$lhs == var.rhs &
        lavpartable$lhs == lavpartable$rhs)

      var.lhs.value <- start[var.lhs.idx]
      var.rhs.value <- start[var.rhs.idx]

      block.txt <- ""
      if (nblocks > 1L) {
        block.txt <- paste(" [in block ", g, "]", sep = "")
      }

      # check for zero variances
      if (var.lhs.value == 0 || var.rhs.value == 0) {
        # this can only happen if it is user-specified
        # cov.idx free? set it to zero
        if (start[this.cov.idx] == 0) {
          # nothing to do
        } else if (lavpartable$free[this.cov.idx] > 0L) {
            lav_msg_warn(gettextf(
             "non-zero covariance element set to zero, due to fixed-to-zero
             variances variables involved are: %s", var.lhs), var.rhs,
             block.txt
            )
          start[this.cov.idx] <- 0
        } else {
          lav_msg_stop(gettextf(
            "please provide better fixed values for (co)variances;
            variables involved are: %s ", var.lhs), var.rhs, block.txt
          )
        }
        next
      }

      # which one is the smallest? abs() in case of negative variances
      if (abs(var.lhs.value) < abs(var.rhs.value)) {
        var.min.idx <- var.lhs.idx
        var.max.idx <- var.rhs.idx
      } else {
        var.min.idx <- var.rhs.idx
        var.max.idx <- var.lhs.idx
      }

      # check
      COR <- abs(start[this.cov.idx] / sqrt(var.lhs.value * var.rhs.value))

      # NOTE: we treat this as an unconditional COR!

      if (!is.finite(COR)) {
        # force simple values
           lav_msg_warn(gettextf(
            "starting values imply NaN for a correlation value; variables
            involved are: %s", var.lhs), var.rhs, block.txt
          )
        start[var.lhs.idx] <- 1
        start[var.rhs.idx] <- 1
        start[this.cov.idx] <- 0
      } else if (COR > 1) {
        txt <- gettextf(
          "starting values imply a correlation larger than 1; variables
          involved are: %1$s %2$s %3$s", var.lhs, var.rhs, block.txt)

        # three ways to fix it: rescale cov12, var1 or var2

        # we prefer a free parameter, and not user-specified
        if (lavpartable$free[this.cov.idx] > 0L &&
          is.na(lavpartable$ustart[this.cov.idx])) {
             lav_msg_warn(gettext(txt))
          start[this.cov.idx] <- start[this.cov.idx] / (COR * 1.1)
        } else if (lavpartable$free[var.min.idx] > 0L &&
          is.na(lavpartable$ustart[var.min.idx])) {
             lav_msg_warn(gettext(txt))
          start[var.min.idx] <- start[var.min.idx] * (COR * 1.1)^2
        } else if (lavpartable$free[var.max.idx] > 0L &&
          is.na(lavpartable$ustart[var.max.idx])) {
             lav_msg_warn(gettext(txt))
          start[var.max.idx] <- start[var.max.idx] * (COR * 1.1)^2

          # not found? try just a free parameter
        } else if (lavpartable$free[this.cov.idx] > 0L) {
             lav_msg_warn(gettext(txt))
          start[this.cov.idx] <- start[this.cov.idx] / (COR * 1.1)
        } else if (lavpartable$free[var.min.idx] > 0L) {
             lav_msg_warn(gettext(txt))
          start[var.min.idx] <- start[var.min.idx] * (COR * 1.1)^2
        } else if (lavpartable$free[var.max.idx] > 0L) {
             lav_msg_warn(gettext(txt))
          start[var.max.idx] <- start[var.max.idx] * (COR * 1.1)^2

          # nothing? abort or warn (and fail later...): warn
        } else {
             lav_msg_warn(gettext(txt))
          # lav_msg_stop(gettextf(
          # "please provide better fixed values for (co)variances;
          #  variables involved are: %s ", var.lhs), var.rhs, block.txt)
        }
      } # COR > 1
    } # cov.idx
  }
  start
}

# collection of functions that deal with rotation matrices
# YR  3 April 2019 -- initial version
# YR  6 Jan 2023: add promax
# YR 30 Jan 2024: orthogonal rotation matrix now reaches the full space

# generate random orthogonal rotation matrix
#
# reference for the orthogonal case:
#
# Stewart, G. W. (1980). The Efficient Generation of Random Orthogonal Matrices
# with an Application to Condition Estimators. SIAM Journal on Numerical
# Analysis, 17(3), 403-409. http://www.jstor.org/stable/2156882
#
lav_matrix_rotate_gen <- function(M = 10L, orthogonal = TRUE) {
  # catch M=1
  if (M == 1L) {
    return(matrix(1, 1, 1))
  }

  if (orthogonal) {
    # create random normal matrix
    tmp <- matrix(rnorm(M * M), nrow = M, ncol = M)
    # use QR decomposition
    qr.out <- qr(tmp)
    Q <- qr.Q(qr.out)
    R <- qr.R(qr.out)
    # ... "normalized so that the diagonal elements of R are positive"
    sign.diag.r <- sign(diag(R))
    out <- Q * rep(sign.diag.r, each = M)
  } else {
    # just normalize *columns* of tmp -> crossprod(out) has 1 on diagonal
    out <- t(t(tmp) / sqrt(diag(crossprod(tmp))))
  }

  out
}

# check if ROT is an orthogonal matrix if orthogonal = TRUE, or normal if
# orthogonal = FALSE
lav_matrix_rotate_check <- function(ROT = NULL, orthogonal = TRUE,
                                    tolerance = sqrt(.Machine$double.eps)) {
  # we assume ROT is a matrix
  M <- nrow(ROT)

  # crossprod
  RR <- crossprod(ROT)

  # target
  if (orthogonal) {
    # ROT^T %*% ROT = I
    target <- diag(M)
  } else {
    # diagonal should be 1
    target <- RR
    diag(target) <- 1
  }

  # compare for near-equality
  res <- all.equal(target = target, current = RR, tolerance = tolerance)

  # return TRUE or FALSE
  if (is.logical(res) && res) {
    out <- TRUE
  } else {
    out <- FALSE
  }

  out
}

# get weights vector needed to weight the rows using Kaiser normalization
lav_matrix_rotate_kaiser_weights <- function(A = NULL) {
  normalize <- 1 / sqrt(rowSums(A * A))
  idxZero <- which(normalize == 0)
  # catch rows with all zero (thanks to Coen Bernaards for suggesting this)
  normalize[idxZero] <- normalize[idxZero] + .Machine$double.eps
  normalize
}

# get weights vector needed to weight the rows using Cureton & Mulaik (1975)
# standardization
# see also Browne (2001) page 128-129
#
# Note: the 'final' weights are mutliplied by the Kaiser weights (see CEFA)
#
lav_matrix_rotate_cm_weights <- function(A = NULL) {
  P <- nrow(A)
  M <- ncol(A)

  # first principal component of AA'
  A.eigen <- eigen(tcrossprod(A), symmetric = TRUE)
  a <- A.eigen$vectors[, 1] * sqrt(A.eigen$values[1])

  Kaiser.weights <- 1 / sqrt(rowSums(A * A))
  a.star <- abs(a * Kaiser.weights) # always between 0 and 1

  m.sqrt.inv <- 1 / sqrt(M)
  acos.m.sqrt.inv <- acos(m.sqrt.inv)

  delta <- numeric(P)
  delta[a.star < m.sqrt.inv] <- pi / 2

  tmp <- (acos.m.sqrt.inv - acos(a.star)) / (acos.m.sqrt.inv - delta) * (pi / 2)

  # add constant (see Cureton & Mulaik, 1975, page 187)
  cm <- cos(tmp) * cos(tmp) + 0.001

  # final weights = weighted by Kaiser weights
  cm * Kaiser.weights
}

# taken from the stats package, but skipping varimax (already done):
lav_matrix_rotate_promax <- function(x, m = 4, varimax.ROT = NULL) {
  # this is based on promax() from factanal.R in /src/library/stats/R

  # 1. create 'ideal' pattern matrix
  Q <- x * abs(x)^(m - 1)

  # 2. regress x on Q to obtain 'rotation matrix' (same as 'procrustes')
  U <- lm.fit(x, Q)$coefficients

  # 3. rescale so that solve(crossprod(U)) has 1 on the diagonal

  d <- diag(solve(t(U) %*% U))
  U <- U %*% diag(sqrt(d))
  dimnames(U) <- NULL

  # 4. create rotated factor matrix
  z <- x %*% U

  # 5. update rotation amtrix
  U <- varimax.ROT %*% U # here we plugin the rotation matrix from varimax

  list(loadings = z, rotmat = U)
}

# utility functions needed to compute various (robust) fit measures:
#
# - lav_fit_catml_dwls (for 'robust' RMSEA/CFI if data is cateogrical)
# - lav_fit_fiml_corrected (correct RMSEA/CFI if data is incomplete)

# compute scaling-factor (c.hat3) for fit.dwls, using fit.catml ingredients
# see:
#     Savalei, V. (2021) Improving Fit Indices In SEM with categorical data.
#     Multivariate Behavioral Research, 56(3), 390-407.
#

# YR Dec 2022: first version
# YR Jan 2023: catml_dwls should check if the input 'correlation' matrix
#              is positive-definite (or not)

lav_fit_catml_dwls <- function(lavobject, check.pd = TRUE) {
  # empty list
  empty.list <- list(
    XX3 = as.numeric(NA), df3 = as.numeric(NA),
    c.hat3 = as.numeric(NA), XX3.scaled = as.numeric(NA),
    XX3.null = as.numeric(NA), df3.null = as.numeric(NA),
    c.hat3.null = as.numeric(NA)
  )

  # limitations
  if (!lavobject@Model@categorical ||
    lavobject@Options$conditional.x ||
    length(unlist(lavobject@pta$vnames$ov.num)) > 0L) {
    return(empty.list)
  } else {
    lavdata <- lavobject@Data
    lavsamplestats <- lavobject@SampleStats
  }

  # check if input matrix (or matrices) are all positive definite
  # (perhaps later, we can rely on 'smoothing', but not for now
  pd.flag <- TRUE
  if (check.pd) {
    for (g in seq_len(lavdata@ngroups)) {
      COR <- lavsamplestats@cov[[g]]
      ev <- eigen(COR, symmetric = TRUE, only.values = TRUE)$values
      if (any(ev < .Machine$double.eps^(1 / 2))) {
        # non-pd!
        pd.flag <- FALSE
        # should we give a warning here? (not for now)
        # warning("lavaan WARNING: robust RMSEA/CFI could not be computed because the input correlation matrix is not positive-definite")
        # what should we do? return NA (for now)
        return(empty.list)
      }
    }
  }

  # 'refit' using estimator = "catML"
  fit.catml <- try(lav_object_catml(lavobject), silent = TRUE)
  if (inherits(fit.catml, "try-error")) {
    return(empty.list)
  }

  XX3 <- fit.catml@test[[1]]$stat
  df3 <- fit.catml@test[[1]]$df


  # compute 'k'
  V <- lavTech(fit.catml, "wls.v") # NT-ML weight matrix

  W.dwls <- lavTech(lavobject, "wls.v") # DWLS weight matrix
  Gamma <- lavTech(lavobject, "gamma") # acov of polychorics
  Delta <- lavTech(lavobject, "delta")
  E.inv <- lavTech(lavobject, "inverted.information")

  fg <- unlist(lavsamplestats@nobs) / lavsamplestats@ntotal

  # Fixme: as we only need the trace, perhaps we could do this
  # group-specific? (see lav_test_satorra_bentler_trace_original)
  V.g <- V
  W.dwls.g <- W.dwls
  Gamma.f <- Gamma
  Delta.g <- Delta
  for (g in seq_len(lavdata@ngroups)) {
    ntotal <- nrow(Gamma[[g]])
    nvar <- lavobject@Model@nvar[[g]]
    pstar <- nvar * (nvar - 1) / 2
    rm.idx <- seq_len(ntotal - pstar)

    # reduce
    Delta.g[[g]] <- Delta[[g]][-rm.idx, , drop = FALSE]
    # reduce and weight
    W.dwls.g[[g]] <- fg[g] * W.dwls[[g]][-rm.idx, -rm.idx]
    V.g[[g]] <- fg[g] * V[[g]] # should already have the right dims
    Gamma.f[[g]] <- 1 / fg[g] * Gamma[[g]][-rm.idx, -rm.idx]
  }
  # create 'big' matrices
  W.dwls.all <- lav_matrix_bdiag(W.dwls.g)
  V.all <- lav_matrix_bdiag(V.g)
  Gamma.all <- lav_matrix_bdiag(Gamma.f)
  Delta.all <- do.call("rbind", Delta.g)

  # compute trace
  WiU.all <- diag(nrow(W.dwls.all)) - Delta.all %*% E.inv %*% t(Delta.all) %*% W.dwls.all
  ks <- sum(diag(t(WiU.all) %*% V.all %*% WiU.all %*% Gamma.all))

  # convert to lavaan 'scaling.factor'
  c.hat3 <- ks / df3
  XX3.scaled <- XX3 / c.hat3

  # baseline model
  XX3.null <- fit.catml@baseline$test[[1]]$stat
  if (is.null(XX3.null)) {
    XX3.null <- as.numeric(NA)
    df3.null <- as.numeric(NA)
    kbs <- as.numeric(NA)
    c.hat3.null <- as.numeric(NA)
  } else {
    df3.null <- fit.catml@baseline$test[[1]]$df
    kbs <- sum(diag(Gamma.all))
    c.hat3.null <- kbs / df3.null
  }

  # return values
  list(
    XX3 = XX3, df3 = df3, c.hat3 = c.hat3, XX3.scaled = XX3.scaled,
    XX3.null = XX3.null, df3.null = df3.null, c.hat3.null = c.hat3.null
  )
}


# compute ingredients to compute FIML-Corrected RMSEA/CFI
# see:
#     Zhang X, Savalei V. (2022). New computations for RMSEA and CFI
#     following FIML and TS estimation with missing data. Psychological Methods.

lav_fit_fiml_corrected <- function(lavobject, baseline.model,
                                   version = "V3") {
  version <- toupper(version)
  if (!version %in% c("V3", "V6")) {
    lav_msg_stop(gettext("only FIML-C(V3) and FIML-C(V6) are available."))
  }

  # empty list
  empty.list <- list(
    XX3 = as.numeric(NA), df3 = as.numeric(NA),
    c.hat3 = as.numeric(NA), XX3.scaled = as.numeric(NA),
    XX3.null = as.numeric(NA), df3.null = as.numeric(NA),
    c.hat3.null = as.numeric(NA)
  )

  # limitations
  if (lavobject@Options$conditional.x ||
    lavobject@Data@nlevels > 1L ||
    is.null(lavobject@h1$implied$cov[[1]])) {
    return(empty.list)
  } else {
    lavdata <- lavobject@Data
    lavsamplestats <- lavobject@SampleStats

    h1 <- lavTech(lavobject, "h1", add.labels = TRUE)
    COV.tilde <- lapply(h1, "[[", "cov")
    MEAN.tilde <- lapply(h1, "[[", "mean")
    sample.nobs <- unlist(lavsamplestats@nobs)
  }

  # 'refit' using 'tilde' (=EM/saturated) sample statistics
  fit.tilde <- try(lavaan(
    model = parTable(lavobject),
    sample.cov = COV.tilde,
    sample.mean = MEAN.tilde,
    sample.nobs = sample.nobs,
    sample.cov.rescale = FALSE,
    information = "observed",
    optim.method = "none",
    se = "none",
    test = "standard",
    baseline = FALSE,
    check.post = FALSE
  ), silent = TRUE)
  if (inherits(fit.tilde, "try-error")) {
    return(empty.list)
  }

  XX3 <- fit.tilde@test[[1]]$stat
  df3 <- fit.tilde@test[[1]]$df

  # compute 'k'

  # V3/V6: always use h1.information = "unstructured"!!
  lavobject@Options$h1.information <- c("unstructured", "unstructured")
  lavobject@Options$observed.information <- c("h1", "h1")
  fit.tilde@Options$h1.information <- c("unstructured", "unstructured")
  fit.tilde@Options$observed.information <- c("h1", "h1")

  Wm <- Wm.g <- lav_model_h1_information_observed(lavobject)
  Wc <- Wc.g <- lav_model_h1_information_observed(fit.tilde)

  if (version == "V3") {
    Jm <- Jm.g <- lav_model_h1_information_firstorder(lavobject)
    Gamma.f <- vector("list", length = lavdata@ngroups)
  }
  Delta <- lavTech(lavobject, "delta")
  E.inv <- lavTech(lavobject, "inverted.information")
  Wmi <- Wmi.g <- try(lapply(Wm, lav_matrix_symmetric_inverse),
    silent = TRUE
  )
  if (inherits(Wmi, "try-error")) {
    return(empty.list)
  }

  fg <- unlist(lavsamplestats@nobs) / lavsamplestats@ntotal
  # Fixme: as we only need the trace, perhaps we could do this
  # group-specific? (see lav_test_satorra_bentler_trace_original)
  for (g in seq_len(lavdata@ngroups)) {
    # group weight
    Wc.g[[g]] <- fg[g] * Wc[[g]]
    Wm.g[[g]] <- fg[g] * Wm[[g]]
    Wmi.g[[g]] <- 1 / fg[g] * Wmi[[g]]

    # Gamma
    if (version == "V3") {
      Jm.g[[g]] <- fg[g] * Jm[[g]]
      Gamma.g <- Wmi[[g]] %*% Jm[[g]] %*% Wmi[[g]]
      Gamma.f[[g]] <- 1 / fg[g] * Gamma.g
    }
  }
  # create 'big' matrices
  Wc.all <- lav_matrix_bdiag(Wc.g)
  Wm.all <- lav_matrix_bdiag(Wm.g)
  Wmi.all <- lav_matrix_bdiag(Wmi.g)
  Delta.all <- do.call("rbind", Delta)

  E.comp <- t(Delta.all) %*% Wc.all %*% Delta.all # VS: or grab from fit.tilde, with observed.info="h1"


  # compute trace
  if (version == "V3") {
    Gamma.all <- lav_matrix_bdiag(Gamma.f)
    # VS: Simplification of k.fimlc to minimize matrix multiplication of big matrices
    Jm.all <- lav_matrix_bdiag(Jm.g)

    # VS: tr11 is also used for baseline
    # VS: tr(AB) = sum(A*t(B)) is more efficient

    tr11 <- sum(Wc.all * Gamma.all)
    tr12 <- sum((t(Delta.all) %*% Jm.all %*% Wmi.all %*% Wc.all %*% Delta.all) * E.inv)
    tr22 <- sum((t(Delta.all) %*% Jm.all %*% Delta.all %*% E.inv) * t(t(Delta.all) %*% Wc.all %*% Delta.all %*% E.inv))

    k.fimlc <- tr11 - 2 * tr12 + tr22
  } else {
    # V6
    tr1 <- sum(Wc.all * Wmi.all)
    k.fimlc <- tr1 - sum(E.comp * E.inv)
  }

  # convert to lavaan 'scaling.factor'
  c.hat3 <- k.fimlc / df3
  XX3.scaled <- XX3 / c.hat3

  # collect temp results
  out <- list(
    XX3 = XX3, df3 = df3,
    c.hat3 = c.hat3, XX3.scaled = XX3.scaled,
    XX3.null = as.numeric(NA), df3.null = as.numeric(NA),
    c.hat3.null = as.numeric(NA)
  )

  # baseline model
  if (!is.null(baseline.model)) {
    fitB <- baseline.model
  } else {
    fitB <- try(lav_object_independence(lavobject), silent = TRUE)
  }

  if (inherits(fitB, "try-error")) {
    return(out)
  }

  # 'refit' using 'tilde' (=EM/saturated) sample statistics
  fitB.tilde <- try(lavaan(
    model = parTable(fitB),
    sample.cov = COV.tilde,
    sample.mean = MEAN.tilde,
    sample.nobs = sample.nobs,
    sample.cov.rescale = FALSE,
    information = "observed",
    optim.method = "none",
    se = "none",
    test = "standard",
    baseline = FALSE,
    check.post = FALSE
  ), silent = TRUE)
  if (inherits(fitB.tilde, "try-error")) {
    return(out)
  }

  XX3.null <- fitB.tilde@test[[1]]$stat
  df3.null <- fitB.tilde@test[[1]]$df

  fitB@Options$h1.information <- c("unstructured", "unstructured")
  fitB@Options$observed.information <- c("h1", "h1")
  fitB.tilde@Options$h1.information <- c("unstructured", "unstructured")
  fitB.tilde@Options$observed.information <- c("h1", "h1")

  E.invB <- lavTech(fitB, "inverted.information")
  DeltaB <- lavTech(fitB, "Delta")
  DeltaB.all <- do.call("rbind", DeltaB)

  E.compB <- t(DeltaB.all) %*% Wc.all %*% DeltaB.all # or grab from fitB.tilde

  # V3 or V6?
  if (version == "V3") {
    tr12B <- sum((t(DeltaB.all) %*% Jm.all %*% Wmi.all %*% Wc.all %*% DeltaB.all) * E.invB)
    tr22B <- sum((t(DeltaB.all) %*% Jm.all %*% DeltaB.all %*% E.invB) * t(t(DeltaB.all) %*% Wc.all %*% DeltaB.all %*% E.invB))
    kb.fimlc <- tr11 - 2 * tr12B + tr22B
  } else {
    # V6
    kb.fimlc <- tr1 - sum(E.compB * E.invB)
  }

  # convert to lavaan 'scaling.factor'
  c.hat3.null <- kb.fimlc / df3.null

  # return values
  list(
    XX3 = XX3, df3 = df3, c.hat3 = c.hat3, XX3.scaled = XX3.scaled,
    XX3.null = XX3.null, df3.null = df3.null, c.hat3.null = c.hat3.null
  )
}

# overview NLMINB (default) versus CONSTR (=constrained optimization)

#                         | cin.simple | nonlinear | no cin
# ----------------------------------------------------------
# eq.constraints (linear) | CONSTR     | CONSTR    | NLMINB
# ceq.nonlinear           | CONSTR     | CONSTR    | CONSTR
# ceq.simple              | NLMINB     | CONSTR    | NLMINB
# no ceq                  | NLMINB     | CONSTR    | NLMINB



# model estimation
lav_model_estimate <- function(lavmodel = NULL,
                               lavpartable = NULL, # for parscale = "stand"
                               lavh1 = NULL, # for multilevel + parsc
                               lavsamplestats = NULL,
                               lavdata = NULL,
                               lavoptions = NULL,
                               lavcache = list(),
                               start = "model",
                               do.fit = TRUE) {
  lavpartable <- lav_partable_set_cache(lavpartable)
  estimator <- lavoptions$estimator
  verbose <- lav_verbose()
  debug <- lav_debug()
  ngroups <- lavsamplestats@ngroups

  if (lavsamplestats@missing.flag || estimator == "PML" ||
      lavdata@nlevels > 1L) {
    group.weight <- FALSE
  } else {
    group.weight <- TRUE
  }

  # backwards compatibility < 0.6-11
  if (is.null(lavoptions$optim.partrace)) {
    lavoptions$optim.partrace <- FALSE
  }

  if (lavoptions$optim.partrace) {
    # fx + parameter values
    PENV <- new.env()
    PENV$PARTRACE <- matrix(NA, nrow = 0, ncol = lavmodel@nx.free + 1L)
  }

  # starting values (ignoring equality constraints)
  x.unpack <- lav_model_get_parameters(lavmodel)

  # override? use simple instead? (new in 0.6-7)
  if (start == "simple") {
    START <- numeric(length(lavpartable$lhs))
    # set loadings to 0.7
    loadings.idx <- which(lavpartable$free > 0L &
      lavpartable$op == "=~")
    if (length(loadings.idx) > 0L) {
      START[loadings.idx] <- 0.7
    }
    # set (only) variances to 1
    var.idx <- which(lavpartable$free > 0L &
      lavpartable$op == "~~" &
      lavpartable$lhs == lavpartable$rhs)
    if (length(var.idx) > 0L) {
      START[var.idx] <- 1
    }

    if (lavmodel@ceq.simple.only) {
      x.unpack <- START[lavpartable$free > 0L &
        !duplicated(lavpartable$free)]
    } else {
      x.unpack <- START[lavpartable$free > 0L]
    }

    # override? use random starting values instead? (new in 0.6-18)
  } else if (start == "random") {
    START <- lav_partable_random(
      lavpartable = lavpartable,
      # needed if we still need to compute bounds:
      lavh1 = lavh1,
      lavdata = lavdata,
      lavsamplestats = lavsamplestats,
      lavoptions = lavoptions
    )

    if (lavmodel@ceq.simple.only) {
      x.unpack <- START[lavpartable$free > 0L &
        !duplicated(lavpartable$free)]
    } else {
      x.unpack <- START[lavpartable$free > 0L]
    }
  }


  # 1. parameter scaling (to handle data scaling, not parameter scaling)
  parscale <- rep(1.0, length(x.unpack))

  # for < 0.6 compatibility
  if (is.null(lavoptions$optim.parscale)) {
    lavoptions$optim.parscale <- "none"
  }

  if (lavoptions$optim.parscale == "none") {
    # do nothing, but still set SCALE, as before


    # 0.6-17:
    # only temporarily: 'keep' this mistake, and change it later:
    # (note the "standarized")
    # we only do this to avoid breaking a test in semlbci
    # } else if(lavoptions$optim.parscale %in% c("stand", "st", "standardize",
    #                                           "standarized", "stand.all")) {

    # this is what it should be:
  } else if (lavoptions$optim.parscale %in% c(
    "stand", "st", "standardize",
    "standardized", "stand.all"
  )) {
    # rescale parameters as if the data was standardized
    # new in 0.6-2
    #
    # FIXME: this works well, as long as the variances of the
    #        latent variables (which we do not know) are more or less
    #        equal to 1.0 (eg std.lv = TRUE)
    #
    #        Once we have better estimates of those variances, we could
    #        use them to set the scale
    #

    if (lavdata@nlevels > 1L) {
      if (length(lavh1) > 0L) {
        OV.VAR <- lapply(lavh1$implied$cov, diag)
      } else {
        OV.VAR <- lapply(
          do.call(c, lapply(lavdata@Lp, "[[", "ov.idx")),
          function(x) rep(1, length(x))
        )
      }
    } else {
      if (lavoptions$conditional.x) {
        OV.VAR <- lavsamplestats@res.var
      } else {
        OV.VAR <- lavsamplestats@var
      }
    }

    if (lavoptions$std.lv) {
      parscale <- lav_standardize_all(
        lavobject = NULL,
        est = rep(1, length(lavpartable$lhs)),
        est.std = rep(1, length(lavpartable$lhs)),
        cov.std = FALSE, ov.var = OV.VAR,
        lavmodel = lavmodel, lavpartable = lavpartable,
        cov.x = lavsamplestats@cov.x
      )
    } else {
      # needs good estimates for lv variances!
      # if there is a single 'marker' indicator, we could use
      # its observed variance as an upper bound

      # for the moment, set them to 1.0 (instead of 0.05)

      # TODO: USE Bentler's 1982 approach to get an estimate of
      # VETA; use those diagonal elements...
      # but only if we have 'marker' indicators for each LV
      LV.VAR <- vector("list", lavmodel@ngroups)
      for (g in seq_len(lavmodel@ngroups)) {
        mm.in.group <- 1:lavmodel@nmat[g] + cumsum(c(0, lavmodel@nmat))[g]
        MLIST <- lavmodel@GLIST[mm.in.group]
        LAMBDA <- MLIST$lambda
        n.lv <- ncol(LAMBDA)
        LV.VAR[[g]] <- rep(1.0, n.lv)
      }

      parscale <- lav_standardize_all(
        lavobject = NULL,
        est = rep(1, length(lavpartable$lhs)),
        # est.std = rep(1, length(lavpartable$lhs)),
        # here, we use whatever the starting values are
        # for the latent variances...
        cov.std = FALSE, ov.var = OV.VAR,
        lv.var = LV.VAR,
        lavmodel = lavmodel, lavpartable = lavpartable,
        cov.x = lavsamplestats@cov.x
      )
    }

    # in addition, take sqrt for variance parameters
    var.idx <- which(lavpartable$op == "~~" &
      lavpartable$lhs == lavpartable$rhs)
    if (length(var.idx) > 0L) {
      parscale[var.idx] <- sqrt(abs(parscale[var.idx]))
    }

    if (lavmodel@ceq.simple.only) {
      parscale <- parscale[lavpartable$free > 0 &
        !duplicated(lavpartable$free)]
    } else {
      parscale <- parscale[lavpartable$free > 0]
    }
  }
  # parscale should obey the equality constraints
  if (lavmodel@eq.constraints && lavoptions$optim.parscale != "none") {
    # pack
    p.pack <- as.numeric((parscale - lavmodel@eq.constraints.k0) %*%
      lavmodel@eq.constraints.K)
    # unpack
    parscale <- as.numeric(lavmodel@eq.constraints.K %*% p.pack) +
      lavmodel@eq.constraints.k0
  }
  if (debug) {
    cat("parscale = ", parscale, "\n")
  }
  z.unpack <- x.unpack * parscale

  # 2. pack (apply equality constraints)
  if (lavmodel@eq.constraints && ncol(lavmodel@eq.constraints.K) > 0L) {
    z.pack <- as.numeric((z.unpack - lavmodel@eq.constraints.k0) %*%
      lavmodel@eq.constraints.K)
  } else {
    z.pack <- z.unpack
  }

  # 3. transform (already constrained) variances to standard deviations?
  # TODO
  # if(lavoptions$optim.var.transform == "sqrt" &&
  #       length(lavmodel@x.free.var.idx) > 0L) {
  #    # transforming variances using atan (or another sigmoid function?)
  #    # FIXME: better approach?
  #    #start.x[lavmodel@x.free.var.idx] <-
  #    #    atan(start.x[lavmodel@x.free.var.idx])
  #    start.x[lavmodel@x.free.var.idx] <-
  #        sqrt(start.x[lavmodel@x.free.var.idx]) # assuming positive var
  # }

  # final starting values for optimizer
  start.x <- z.pack
  if (debug) {
    cat("start.x = ", start.x, "\n")
  }

  # user-specified bounds? (new in 0.6-2)
  if (is.null(lavpartable$lower)) {
    lower <- -Inf
  } else {
    if (lavmodel@ceq.simple.only) {
      free.idx <- which(lavpartable$free > 0L &
        !duplicated(lavpartable$free))
      lower <- lavpartable$lower[free.idx]
    } else if (lavmodel@eq.constraints) {
      # bounds have no effect any longer....
      # 0.6-19 -> we switch to constrained estimation
      #lav_msg_warn(gettext(
      #  "bounds have no effect in the presence of linear equality constraints"))
      lower <- -Inf
    } else {
      lower <- lavpartable$lower[lavpartable$free > 0L]
    }
  }
  if (is.null(lavpartable$upper)) {
    upper <- +Inf
  } else {
    if (lavmodel@ceq.simple.only) {
      free.idx <- which(lavpartable$free > 0L &
        !duplicated(lavpartable$free))
      upper <- lavpartable$upper[free.idx]
    } else if (lavmodel@eq.constraints) {
      # bounds have no effect any longer....
      if (is.null(lavpartable$lower)) {
        # bounds have no effect any longer....
        # 0.6-19 -> we switch to constrained estimation
        #lav_msg_warn(gettext(
        #"bounds have no effect in the presence of linear equality constraints"))
      }
      upper <- +Inf
    } else {
      upper <- lavpartable$upper[lavpartable$free > 0L]
    }
  }

  # check for inconsistent lower/upper bounds
  # this may happen if we have equality constraints; qr() may switch
  # the sign...
  bad.idx <- which(lower > upper)
  if (length(bad.idx) > 0L) {
    # switch
    # tmp <- lower[bad.idx]
    # lower[bad.idx] <- upper[bad.idx]
    # upper[bad.idx] <- tmp
    lower[bad.idx] <- -Inf
    upper[bad.idx] <- +Inf
  }

  # function to be minimized
  objective_function <- function(x, verbose = FALSE, infToMax = FALSE,
                                 debug = FALSE) {
    # 3. standard deviations to variances
    # WARNING: x is still packed here!
    # if(lavoptions$optim.var.transform == "sqrt" &&
    #   length(lavmodel@x.free.var.idx) > 0L) {
    #    #x[lavmodel@x.free.var.idx] <- tan(x[lavmodel@x.free.var.idx])
    #    x.var <- x[lavmodel@x.free.var.idx]
    #    x.var.sign <- sign(x.var)
    #    x[lavmodel@x.free.var.idx] <- x.var.sign * (x.var * x.var) # square!
    # }

    # 2. unpack
    if (lavmodel@eq.constraints) {
      x <- as.numeric(lavmodel@eq.constraints.K %*% x) +
        lavmodel@eq.constraints.k0
    }

    # 1. unscale
    x <- x / parscale

    # update GLIST (change `state') and make a COPY!
    GLIST <- lav_model_x2glist(lavmodel, x = x)

    fx <- lav_model_objective(
      lavmodel = lavmodel,
      GLIST = GLIST,
      lavsamplestats = lavsamplestats,
      lavdata = lavdata,
      lavcache = lavcache
    )

    # only for PML: divide by N (to speed up convergence)
    if (estimator == "PML") {
      fx <- fx / lavsamplestats@ntotal
    }



    if (debug || verbose) {
      cat("  objective function  = ",
        sprintf("%18.16f", fx), "\n",
        sep = ""
      )
    }
    if (debug) {
      # cat("Current unconstrained parameter values =\n")
      # tmp.x <- lav_model_get_parameters(lavmodel, GLIST=GLIST, type="unco")
      # print(tmp.x); cat("\n")
      cat("Current free parameter values =\n")
      print(x)
      cat("\n")
    }

    if (lavoptions$optim.partrace) {
      PENV$PARTRACE <- rbind(PENV$PARTRACE, c(fx, x))
    }

    # for L-BFGS-B
    # if(infToMax && is.infinite(fx)) fx <- 1e20
    if (!is.finite(fx)) {
      fx.group <- attr(fx, "fx.group")
      fx <- 1e20
      attr(fx, "fx.group") <- fx.group # only for lav_model_fit()
    }

    fx
  }

  gradient_function <- function(x, verbose = FALSE, infToMax = FALSE,
                                debug = FALSE) {
    # transform variances back
    # if(lavoptions$optim.var.transform == "sqrt" &&
    #   length(lavmodel@x.free.var.idx) > 0L) {
    #    #x[lavmodel@x.free.var.idx] <- tan(x[lavmodel@x.free.var.idx])
    #    x.var <- x[lavmodel@x.free.var.idx]
    #    x.var.sign <- sign(x.var)
    #    x[lavmodel@x.free.var.idx] <- x.var.sign * (x.var * x.var) # square!
    # }

    # 2. unpack
    if (lavmodel@eq.constraints) {
      x <- as.numeric(lavmodel@eq.constraints.K %*% x) +
        lavmodel@eq.constraints.k0
    }

    # 1. unscale
    x <- x / parscale

    # update GLIST (change `state') and make a COPY!
    GLIST <- lav_model_x2glist(lavmodel, x = x)

    dx <- lav_model_gradient(
      lavmodel = lavmodel,
      GLIST = GLIST,
      lavsamplestats = lavsamplestats,
      lavdata = lavdata,
      lavcache = lavcache,
      type = "free",
      group.weight = group.weight, ### check me!!
      ceq.simple = lavmodel@ceq.simple.only
    )

    if (debug) {
      cat("Gradient function (analytical) =\n")
      print(dx)
      cat("\n")
    }

    # 1. scale (note: divide, not multiply!)
    dx <- dx / parscale

    # 2. pack
    if (lavmodel@eq.constraints) {
      dx <- as.numeric(dx %*% lavmodel@eq.constraints.K)
    }

    # 3. transform variances back
    # if(lavoptions$optim.var.transform == "sqrt" &&
    #   length(lavmodel@x.free.var.idx) > 0L) {
    #    x.var <- x[lavmodel@x.free.var.idx] # here in 'var' metric
    #    x.var.sign <- sign(x.var)
    #    x.var <- abs(x.var)
    #    x.sd <- sqrt(x.var)
    #    dx[lavmodel@x.free.var.idx] <-
    #        ( 2 * x.var.sign * dx[lavmodel@x.free.var.idx] * x.sd )
    # }

    # only for PML: divide by N (to speed up convergence)
    if (estimator == "PML") {
      dx <- dx / lavsamplestats@ntotal
    }

    if (debug) {
      cat("Gradient function (analytical, after eq.constraints.K) =\n")
      print(dx)
      cat("\n")
    }

    dx
  }

  gradient_function_numerical <- function(x, verbose = FALSE, debug = FALSE) {
    # NOTE: no need to 'tranform' anything here (var/eq)
    # this is done anyway in objective_function

    # numerical approximation using the Richardson method
    npar <- length(x)
    h <- 10e-6
    dx <- numeric(npar)

    ## FIXME: call lav_model_objective directly!!
    for (i in 1:npar) {
      x.left <- x.left2 <- x.right <- x.right2 <- x
      x.left[i] <- x[i] - h
      x.left2[i] <- x[i] - 2 * h
      x.right[i] <- x[i] + h
      x.right2[i] <- x[i] + 2 * h
      fx.left <- objective_function(x.left, verbose = FALSE, debug = FALSE)
      fx.left2 <- objective_function(x.left2, verbose = FALSE, debug = FALSE)
      fx.right <- objective_function(x.right, verbose = FALSE, debug = FALSE)
      fx.right2 <- objective_function(x.right2, verbose = FALSE, debug = FALSE)
      dx[i] <- (fx.left2 - 8 * fx.left + 8 * fx.right - fx.right2) / (12 * h)
    }

    # dx <- lavGradientC(func=objective_function, x=x)
    # does not work if pnorm is involved... (eg PML)

    if (debug) {
      cat("Gradient function (numerical) =\n")
      print(dx)
      cat("\n")
    }

    dx
  }

  gradient_function_numerical_complex <- function(x, verbose = FALSE, debug = FALSE) {
    dx <- Re(lav_func_gradient_complex(
      func = objective_function, x = x,
      h = sqrt(.Machine$double.eps)
    ))
    # does not work if pnorm is involved... (eg PML)

    if (debug) {
      cat("Gradient function (numerical complex) =\n")
      print(dx)
      cat("\n")
    }

    dx
  }


  # check if the initial values produce a positive definite Sigma
  # to begin with -- but only for estimator="ML"
  if (estimator %in% c("ML", "FML", "MML")) {
    Sigma.hat <- lav_model_sigma(lavmodel, extra = TRUE)
    for (g in 1:ngroups) {
      if (!attr(Sigma.hat[[g]], "po")) {
        group.txt <-
          if(ngroups > 1) gettextf(" in group %s.", g) else "."
        if (debug) {
          print(Sigma.hat[[g]][, ])
        }
        lav_msg_warn(gettext(
          "initial model-implied matrix (Sigma) is not positive definite;
          check your model and/or starting parameters"), group.txt)
        x <- start.x
        fx <- as.numeric(NA)
        attr(fx, "fx.group") <- rep(as.numeric(NA), ngroups)
        attr(x, "converged") <- FALSE
        attr(x, "iterations") <- 0L
        attr(x, "control") <- lavoptions$control
        attr(x, "fx") <- fx
        return(x)
      }
    }
  }


  # parameter scaling
  # FIXME: what is the best way to set the scale??
  # current strategy: if startx > 1.0, we rescale by using
  # 1/startx
  SCALE <- rep(1.0, length(start.x))
  if (lavoptions$optim.parscale == "none") {
    idx <- which(abs(start.x) > 1.0)
    if (length(idx) > 0L) {
      SCALE[idx] <- abs(1.0 / start.x[idx])
    }
  }
  if (debug) {
    cat("SCALE = ", SCALE, "\n")
  }


  # first try: check if starting values return a finite value
  fx <- objective_function(start.x, verbose = verbose, debug = debug)
  if (!is.finite(fx)) {
    # emergency change of start.x
    start.x <- start.x / 10
  }



  # first some nelder mead steps? (default = FALSE)
  INIT_NELDER_MEAD <- lavoptions$optim.init_nelder_mead

  # gradient: analytic, numerical or NULL?
  if (is.character(lavoptions$optim.gradient)) {
    if (lavoptions$optim.gradient %in% c("analytic", "analytical")) {
      GRADIENT <- gradient_function
    } else if (lavoptions$optim.gradient %in% c("numerical", "numeric")) {
      GRADIENT <- gradient_function_numerical
    } else if (lavoptions$optim.gradient %in% c("numeric.complex", "complex")) {
      GRADIENT <- gradient_function_numerical_complex
    } else if (lavoptions$optim.gradient %in% c("NULL", "null")) {
      GRADIENT <- NULL
    } else {
      lav_msg_warn(gettext("gradient should be analytic, numerical or NULL"))
    }
  } else if (is.logical(lavoptions$optim.gradient)) {
    if (lavoptions$optim.gradient) {
      GRADIENT <- gradient_function
    } else {
      GRADIENT <- NULL
    }
  } else if (is.null(lavoptions$optim.gradient)) {
    GRADIENT <- gradient_function
  }


  # default optimizer
  if (length(lavmodel@ceq.nonlinear.idx) == 0L &&
      (lavmodel@cin.simple.only || (length(lavmodel@cin.linear.idx)    == 0L &&
                                    length(lavmodel@cin.nonlinear.idx) == 0L))
     ) {
    if (is.null(lavoptions$optim.method)) {
      OPTIMIZER <- "NLMINB"
      # OPTIMIZER <- "BFGS"  # slightly slower, no bounds; better scaling!
      # OPTIMIZER <- "L-BFGS-B"  # trouble with Inf values for fx!
    } else {
      OPTIMIZER <- toupper(lavoptions$optim.method)
      stopifnot(OPTIMIZER %in% c(
        "NLMINB0", "NLMINB1", "NLMINB2",
        "NLMINB", "BFGS", "L.BFGS.B", "NONE"
      ))
      if (OPTIMIZER == "NLMINB1") {
        OPTIMIZER <- "NLMINB"
      }
    }
  } else {
    if (is.null(lavoptions$optim.method)) {
      OPTIMIZER <- "NLMINB.CONSTR"
    } else {
      OPTIMIZER <- toupper(lavoptions$optim.method)
      stopifnot(OPTIMIZER %in% c("NLMINB.CONSTR", "NLMINB", "NONE"))
    }
    if (OPTIMIZER == "NLMINB") {
      OPTIMIZER <- "NLMINB.CONSTR"
    }
  }

  if (INIT_NELDER_MEAD) {
    if (verbose) cat("  initial Nelder-Mead step:\n")
    trace <- 0L
    if (verbose) trace <- 1L
    optim.out <- optim(
      par = start.x,
      fn = objective_function,
      method = "Nelder-Mead",
      # control=list(maxit=10L,
      #             parscale=SCALE,
      #             trace=trace),
      hessian = FALSE,
      verbose = verbose, debug = debug
    )
    cat("\n")
    start.x <- optim.out$par
  }



  if (OPTIMIZER == "NLMINB0") {
    if (verbose) cat("  quasi-Newton steps using NLMINB0 (no analytic gradient):\n")
    # if(debug) control$trace <- 1L;
    control.nlminb <- list(
      eval.max = 20000L,
      iter.max = 10000L,
      trace = 0L,
      # abs.tol=1e-20, ### important!! fx never negative
      abs.tol = (.Machine$double.eps * 10),
      rel.tol = 1e-10,
      # step.min=2.2e-14, # in =< 0.5-12
      step.min = 1.0, # 1.0 in < 0.5-21
      step.max = 1.0,
      x.tol = 1.5e-8,
      xf.tol = 2.2e-14
    )
    control.nlminb <- modifyList(control.nlminb, lavoptions$control)
    control <- control.nlminb[c(
      "eval.max", "iter.max", "trace",
      "step.min", "step.max",
      "abs.tol", "rel.tol", "x.tol", "xf.tol"
    )]
    # cat("DEBUG: control = "); print(str(control.nlminb)); cat("\n")
    optim.out <- nlminb(
      start = start.x,
      objective = objective_function,
      gradient = NULL,
      lower = lower,
      upper = upper,
      control = control,
      scale = SCALE,
      verbose = verbose, debug = debug
    )
    if (verbose) {
      cat("  convergence status (0=ok): ", optim.out$convergence, "\n")
      cat("  nlminb message says: ", optim.out$message, "\n")
      cat("  number of iterations: ", optim.out$iterations, "\n")
      cat(
        "  number of function evaluations [objective, gradient]: ",
        optim.out$evaluations, "\n"
      )
    }

    # try again
    if (optim.out$convergence != 0L) {
      optim.out <- nlminb(
        start = start.x,
        objective = objective_function,
        gradient = NULL,
        lower = lower,
        upper = upper,
        control = control,
        scale = SCALE,
        verbose = verbose, debug = debug
      )
    }

    iterations <- optim.out$iterations
    x <- optim.out$par
    if (optim.out$convergence == 0L) {
      converged <- TRUE
    } else {
      converged <- FALSE
    }
  } else if (OPTIMIZER == "NLMINB") {
    if (verbose) cat("  quasi-Newton steps using NLMINB:\n")
    # if(debug) control$trace <- 1L;
    control.nlminb <- list(
      eval.max = 20000L,
      iter.max = 10000L,
      trace = 0L,
      # abs.tol=1e-20, ### important!! fx never negative
      abs.tol = (.Machine$double.eps * 10),
      rel.tol = 1e-10,
      # step.min=2.2e-14, # in =< 0.5-12
      step.min = 1.0, # 1.0 in < 0.5-21
      step.max = 1.0,
      x.tol = 1.5e-8,
      xf.tol = 2.2e-14
    )
    control.nlminb <- modifyList(control.nlminb, lavoptions$control)
    control <- control.nlminb[c(
      "eval.max", "iter.max", "trace",
      "step.min", "step.max",
      "abs.tol", "rel.tol", "x.tol", "xf.tol"
    )]
    # cat("DEBUG: control = "); print(str(control.nlminb)); cat("\n")
    optim.out <- nlminb(
      start = start.x,
      objective = objective_function,
      gradient = GRADIENT,
      lower = lower,
      upper = upper,
      control = control,
      scale = SCALE,
      verbose = verbose, debug = debug
    )
    if (verbose) {
      cat("  convergence status (0=ok): ", optim.out$convergence, "\n")
      cat("  nlminb message says: ", optim.out$message, "\n")
      cat("  number of iterations: ", optim.out$iterations, "\n")
      cat(
        "  number of function evaluations [objective, gradient]: ",
        optim.out$evaluations, "\n"
      )
    }

    iterations <- optim.out$iterations
    x <- optim.out$par
    if (optim.out$convergence == 0L) {
      converged <- TRUE
    } else {
      converged <- FALSE
    }
  } else if (OPTIMIZER == "BFGS") {
    # warning: Bollen example with estimator=GLS does NOT converge!
    # (but WLS works!)
    # - BB.ML works too

    control.bfgs <- list(
      trace = 0L, fnscale = 1,
      parscale = SCALE, ## or not?
      ndeps = 1e-3,
      maxit = 10000,
      abstol = 1e-20,
      reltol = 1e-10,
      REPORT = 1L
    )
    control.bfgs <- modifyList(control.bfgs, lavoptions$control)
    control <- control.bfgs[c(
      "trace", "fnscale", "parscale", "ndeps",
      "maxit", "abstol", "reltol", "REPORT"
    )]
    # trace <- 0L; if(verbose) trace <- 1L
    optim.out <- optim(
      par = start.x,
      fn = objective_function,
      gr = GRADIENT,
      method = "BFGS",
      control = control,
      hessian = FALSE,
      verbose = verbose, debug = debug
    )
    if (verbose) {
      cat("  convergence status (0=ok): ", optim.out$convergence, "\n")
      cat("  optim BFGS message says: ", optim.out$message, "\n")
      # cat("number of iterations: ", optim.out$iterations, "\n")
      cat(
        "  number of function evaluations [objective, gradient]: ",
        optim.out$counts, "\n"
      )
    }

    # iterations <- optim.out$iterations
    iterations <- optim.out$counts[1]
    x <- optim.out$par
    if (optim.out$convergence == 0L) {
      converged <- TRUE
    } else {
      converged <- FALSE
    }
  } else if (OPTIMIZER == "L.BFGS.B") {
    # warning, does not cope with Inf values!!

    control.lbfgsb <- list(
      trace = 0L, fnscale = 1,
      parscale = SCALE, ## or not?
      ndeps = 1e-3,
      maxit = 10000,
      REPORT = 1L,
      lmm = 5L,
      factr = 1e7,
      pgtol = 0
    )
    control.lbfgsb <- modifyList(control.lbfgsb, lavoptions$control)
    control <- control.lbfgsb[c(
      "trace", "fnscale", "parscale",
      "ndeps", "maxit", "REPORT", "lmm",
      "factr", "pgtol"
    )]
    optim.out <- optim(
      par = start.x,
      fn = objective_function,
      gr = GRADIENT,
      method = "L-BFGS-B",
      lower = lower,
      upper = upper,
      control = control,
      hessian = FALSE,
      verbose = verbose, debug = debug,
      infToMax = TRUE
    )
    if (verbose) {
      cat("  convergence status (0=ok): ", optim.out$convergence, "\n")
      cat("  optim L-BFGS-B message says: ", optim.out$message, "\n")
      # cat("number of iterations: ", optim.out$iterations, "\n")
      cat(
        "  number of function evaluations [objective, gradient]: ",
        optim.out$counts, "\n"
      )
    }

    # iterations <- optim.out$iterations
    iterations <- optim.out$counts[1]
    x <- optim.out$par
    if (optim.out$convergence == 0L) {
      converged <- TRUE
    } else {
      converged <- FALSE
    }
  } else if (OPTIMIZER == "NLMINB.CONSTR") {
    ocontrol <- list(verbose = verbose)
    if (!is.null(lavoptions$control$control.outer)) {
      ocontrol <- c(lavoptions$control$control.outer, verbose = verbose)
    }
    control.nlminb <- list(
      eval.max = 20000L,
      iter.max = 10000L,
      trace = 0L,
      # abs.tol=1e-20,
      abs.tol = (.Machine$double.eps * 10),
      rel.tol = 1e-9, # 1e-10 seems 'too strict'
      step.min = 1.0, # 1.0 in < 0.5-21
      step.max = 1.0,
      x.tol = 1.5e-8,
      xf.tol = 2.2e-14
    )
    control.nlminb <- modifyList(control.nlminb, lavoptions$control)
    control <- control.nlminb[c(
      "eval.max", "iter.max", "trace",
      "abs.tol", "rel.tol"
    )]
    cin <- cin.jac <- ceq <- ceq.jac <- NULL
    if (!is.null(body(lavmodel@cin.function))) cin <- lavmodel@cin.function
    if (!is.null(body(lavmodel@cin.jacobian))) cin.jac <- lavmodel@cin.jacobian
    if (!is.null(body(lavmodel@ceq.function))) ceq <- lavmodel@ceq.function
    if (!is.null(body(lavmodel@ceq.jacobian))) ceq.jac <- lavmodel@ceq.jacobian
    trace <- FALSE
    if (verbose) trace <- TRUE
    optim.out <- nlminb.constr(
      start = start.x,
      objective = objective_function,
      gradient = GRADIENT,
      control = control,
      scale = SCALE,
      verbose = verbose, debug = debug,
      lower = lower,
      upper = upper,
      cin = cin, cin.jac = cin.jac,
      ceq = ceq, ceq.jac = ceq.jac,
      control.outer = ocontrol
    )
    if (verbose) {
      cat("  convergence status (0=ok): ", optim.out$convergence, "\n")
      cat("  nlminb.constr message says: ", optim.out$message, "\n")
      cat("  number of outer iterations: ", optim.out$outer.iterations, "\n")
      cat("  number of inner iterations: ", optim.out$iterations, "\n")
      cat(
        "  number of function evaluations [objective, gradient]: ",
        optim.out$evaluations, "\n"
      )
    }

    iterations <- optim.out$iterations
    x <- optim.out$par
    if (optim.out$convergence == 0) {
      converged <- TRUE
    } else {
      converged <- FALSE
    }
  } else if (OPTIMIZER == "NONE") {
    x <- start.x
    iterations <- 0L
    converged <- TRUE
    control <- list()

    # if inequality constraints, add con.jac/lambda
    # needed for df!
    if (length(lavmodel@ceq.nonlinear.idx) == 0L &&
        (lavmodel@cin.simple.only ||
         (length(lavmodel@cin.linear.idx) == 0L &&
          length(lavmodel@cin.nonlinear.idx) == 0L))) {
      optim.out <- list()
    } else {
      # if inequality constraints, add con.jac/lambda
      # needed for df!

      optim.out <- list()
      if (is.null(body(lavmodel@ceq.function))) {
        ceq <- function(x, ...) {
          return(numeric(0))
        }
      } else {
        ceq <- lavmodel@ceq.function
      }
      if (is.null(body(lavmodel@cin.function))) {
        cin <- function(x, ...) {
          return(numeric(0))
        }
      } else {
        cin <- lavmodel@cin.function
      }
      ceq0 <- ceq(start.x)
      cin0 <- cin(start.x)
      con0 <- c(ceq0, cin0)
      JAC <- rbind(
        numDeriv::jacobian(ceq, x = start.x),
        numDeriv::jacobian(cin, x = start.x)
      )
      nceq <- length(ceq(start.x))
      ncin <- length(cin(start.x))
      ncon <- nceq + ncin
      ceq.idx <- cin.idx <- integer(0)
      if (nceq > 0L) ceq.idx <- 1:nceq
      if (ncin > 0L) cin.idx <- nceq + 1:ncin
      cin.flag <- rep(FALSE, length(ncon))
      if (ncin > 0L) cin.flag[cin.idx] <- TRUE

      inactive.idx <- integer(0L)
      cin.idx <- which(cin.flag)
      if (ncin > 0L) {
        slack <- 1e-05
        inactive.idx <- which(cin.flag & con0 > slack)
      }
      attr(JAC, "inactive.idx") <- inactive.idx
      attr(JAC, "cin.idx") <- cin.idx
      attr(JAC, "ceq.idx") <- ceq.idx

      optim.out$con.jac <- JAC
      optim.out$lambda <- rep(0, ncon)
    }
  }

  # new in 0.6-19
  # if NLMINB() + cin.simple.only, add con.jac and lambda to optim.out
  if (OPTIMIZER %in% c("NLMINB", "NLMINB0", "L.BFGS.B") &&
      (lavmodel@cin.simple.only || lavmodel@ceq.simple.only)) {

    if (lavmodel@cin.simple.only && nrow(lavmodel@cin.JAC) > 0L) {
      # JAC
      cin.JAC <- lavmodel@cin.JAC
      con0 <- lavmodel@cin.function(x)
      slack <- 1e-05
      inactive.idx <- which(abs(con0) > slack)

      # lambda
      # FIXME! HOW to compute this (post-hoc)?
      dx <- GRADIENT(x)
      if(lavmodel@ceq.simple.only) {
        dx.unpack <- numeric(ncol(cin.JAC))
        dx.unpack <- dx[lavpartable$free[lavpartable$free > 0]]
      } else if (lavmodel@eq.constraints) {
        # this should not happen!
        cat("\n DEBUG: NLMINB + cin.simple.only + lavmodel@eq.constraints \n")
        dx.unpack <- as.numeric(lavmodel@eq.constraints.K %*% dx)
      } else {
        dx.unpack <- dx
      }
      cin.lambda <- drop(cin.JAC %*% dx.unpack)
      cin.lambda[inactive.idx] <- 0

      # remove all inactive rows
      #if (length(inactive.idx) > 0L) {
      #  cin.JAC <- cin.JAC[-inactive.idx, , drop = FALSE]
      #  cin.lambda <- cin.lambda[-inactive.idx]
      #  inactive.idx <- integer(0L)
      #}
    } else {
      npar <- length(lavpartable$free[lavpartable$free > 0])
      cin.JAC <- matrix(0, nrow = 0L, ncol = npar)
      inactive.idx <- integer(0L)
      cin.lambda <- numeric(0L)
    }

    if (lavmodel@ceq.simple.only && nrow(lavmodel@ceq.simple.K) > 0L) {
      ceq.JAC <- t(lav_matrix_orthogonal_complement(lavmodel@ceq.simple.K))
      ceq.lambda <- numeric(nrow(ceq.JAC))
    } else {
      npar <- length(lavpartable$free[lavpartable$free > 0])
      ceq.JAC <- matrix(0, nrow = 0L, ncol = npar)
      ceq.lambda <- numeric(0L)
    }

    # combine
    JAC <- rbind(cin.JAC, ceq.JAC)
    attr(JAC, "inactive.idx") <- inactive.idx
    attr(JAC, "cin.idx") <- seq_len(nrow(cin.JAC))
    attr(JAC, "ceq.idx") <- nrow(cin.JAC) + seq_len(nrow(ceq.JAC))
    lambda <- c(cin.lambda, ceq.lambda)

    optim.out$con.jac <- JAC
    optim.out$lambda <- lambda
  }


  fx <- objective_function(x) # to get "fx.group" attribute

  # check convergence
  warn.txt <- ""
  if (converged) {
    # check.gradient
    if (!is.null(GRADIENT) &&
      OPTIMIZER %in% c("NLMINB", "BFGS", "L.BFGS.B")) {
      # compute unscaled gradient
      dx <- GRADIENT(x)

      # NOTE: unscaled gradient!!!
      if (converged && lavoptions$check.gradient &&
        any(abs(dx) > lavoptions$optim.dx.tol)) {
        # ok, identify the non-zero elements
        non.zero <- which(abs(dx) > lavoptions$optim.dx.tol)

        # which ones are 'boundary' points, defined by lower/upper?
        bound.idx <- integer(0L)
        if (!is.null(lavpartable$lower)) {
          bound.idx <- c(bound.idx, which(lower == x))
        }
        if (!is.null(lavpartable$upper)) {
          bound.idx <- c(bound.idx, which(upper == x))
        }
        if (length(bound.idx) > 0L) {
          non.zero <- non.zero[-which(non.zero %in% bound.idx)]
        }

        # this has many implications ... so should be careful to
        # avoid false alarm
        if (length(non.zero) > 0L) {
          converged <- FALSE
          warn.txt <- paste("the optimizer (", OPTIMIZER, ") ",
            "claimed the model converged,\n",
            "                      but not all elements of the gradient are (near) zero;\n",
            "                      the optimizer may not have found a local solution\n",
            "                      use check.gradient = FALSE to skip this check.",
            sep = ""
          )
        }
      }
    } else {
      dx <- numeric(0L)
    }
  } else {
    dx <- numeric(0L)
    warn.txt <- "the optimizer warns that a solution has NOT been found!"
  }

  # transform back
  # 3.
  # if(lavoptions$optim.var.transform == "sqrt" &&
  #       length(lavmodel@x.free.var.idx) > 0L) {
  #    #x[lavmodel@x.free.var.idx] <- tan(x[lavmodel@x.free.var.idx])
  #    x.var <- x[lavmodel@x.free.var.idx]
  #    x.var.sign <- sign(x.var)
  #    x[lavmodel@x.free.var.idx] <- x.var.sign * (x.var * x.var) # square!
  # }

  # 2. unpack
  if (lavmodel@eq.constraints) {
    x <- as.numeric(lavmodel@eq.constraints.K %*% x) +
      lavmodel@eq.constraints.k0
  }

  # 1. unscale
  x <- x / parscale

  attr(x, "converged") <- converged
  attr(x, "start") <- start.x
  attr(x, "warn.txt") <- warn.txt
  attr(x, "iterations") <- iterations
  attr(x, "control") <- control
  attr(x, "fx") <- fx
  attr(x, "dx") <- dx
  attr(x, "parscale") <- parscale
  if (!is.null(optim.out$con.jac)) attr(x, "con.jac") <- optim.out$con.jac
  if (!is.null(optim.out$lambda)) attr(x, "con.lambda") <- optim.out$lambda
  if (lavoptions$optim.partrace) {
    attr(x, "partrace") <- PENV$PARTRACE
  }

  x
}

# backwards compatibility
# estimateModel <- lav_model_estimate

# functions related to the RMSEA index of approximate fit

# lower-level functions: no checking of input: just compute the number(s):
# - lav_fit_rmsea
# - lav_fit_rmsea_ci
# - lav_fit_rmsea_closefit
# - lav_fit_rmsea_notclosefit (TODO)

# higher-level functions:
# - lav_fit_rmsea_lavobject

# Y.R. 19 July 2022

# we assume X2 = N * F.val
# lambda = (X2 - df) is the non-centrality parameter

# RMSEA: sqrt( (X2 - df)/(N * df) )
#      = sqrt( lambda/(N * df) )
#      = sqrt( ((N*F.val) - df)/(N * df) )
#      = sqrt( (N.F.val)/(N * df) - df/(N * df) )
#      = sqrt( F.val/df - 1/N )
#      = sqrt( (X2/N)/df - 1/N )


# 'scaled' RMSEA: X2 is replaced by X2-SB (or any other 'scaled' statistic)

# robust RMSEA: sqrt( (X2/N)/df - c.hat/N )
# note:
# - robust RMSEA == scaled RMSEA * sqrt(c.hat)
# - robust RMSEA CI == scaled RMSEA CI * sqrt(c.hat)

# robust RMSEA for MLMV (ie. scaled.shifted):
# - c == a * (df - b) / df
# - robust RMSEA MLM == robust RMSEA MLMV
# - robust RMSEA MLMV == scaled RMSEA MLMV * sqrt(a)
# - robust RMSEA CI MLMV == scaled RMSEA CI MLMV * sqrt(a)

# References:
# Steiger, J. H., & Lind, J. C. (1980, May). Statistically based tests for the
# number of common factors.  Paper presented at the annual meeting of the
# Psychometric Society, Iowa City, IA.

# confidence interval:
# Browne, M. W., & Cudeck, R. (1993). Alternative ways of assessing model fit.
# In K. A. Bollen & J. S. Long (Eds.), Testing structural equation models (pp.
# 136-162). Newbury Park, CA: Sage.

# problems with low df
# Kenny, D. A., Kaniskan, B., & McCoach, D. B. (2015).  The performance of RMSEA
# in models with small degrees of freedom.  Sociological Methods & Research, 44,
# 486-507.

# robust version MLM
# Patricia E. Brosseau-Liard , Victoria Savalei & Libo Li (2012) An
# Investigation of the Sample Performance of Two Nonnormality Corrections for
# RMSEA, Multivariate Behavioral Research, 47:6, 904-930, DOI:
# 10.1080/00273171.2012.715252

# robust version MLMV (scaled.shifted)
# Savalei, V. (2018). On the computation of the RMSEA and CFI from the
# mean-and-variance corrected test statistic with nonnormal data in SEM.
# Multivariate behavioral research, 53(3), 419-429.

# categorical data:
# Savalei, V. (2021). Improving fit indices in structural equation modeling with
# categorical data. Multivariate Behavioral Research, 56(3), 390-407. doi:
# 10.1080/00273171.2020.1717922

# missing = "fiml":
# Zhang, X., & Savalei, V. (2022). New computations for RMSEA and CFI following
# FIML and TS estimation with missing data. Psychological Methods.


# always using N (if a user needs N-1, just replace N by N-1)
# vectorized!
lav_fit_rmsea <- function(X2 = NULL, df = NULL, N = NULL,
                          F.val = NULL, G = 1L, c.hat = 1.0) {
  # did we get a sample size?
  if (missing(N) && !missing(F.val)) {
    # population version
    RMSEA <- sqrt(F.val / df)
  } else {
    nel <- length(X2)
    if (nel == 0) {
      return(as.numeric(NA))
    }
    RMSEA <- ifelse(df > 0,
      # 'standard' way to compute RMSEA
      RMSEA <- sqrt(pmax((X2 / N) / df - c.hat / N, rep(0, nel))) * sqrt(G),
      0
    ) # if df == 0
  }

  RMSEA
}

# note: for 'robust' version, X2 should be SB-X2
lav_fit_rmsea_ci <- function(X2 = NULL, df = NULL, N = NULL,
                             G = 1L, c.hat = 1, level = 0.90) {
  if (missing(N) || missing(X2) || missing(df) ||
    !is.finite(X2) || !is.finite(df) || !is.finite(N)) {
    return(list(
      rmsea.ci.lower = as.numeric(NA),
      rmsea.ci.upper = as.numeric(NA)
    ))
  }

  if (!is.finite(level) || level < 0 || level > 1.0) {
    lav_msg_warn(gettextf(
      "invalid level value [%s] set to default 0.90.", level
    ))
    level <- 0.90
  }

  upper.perc <- (1 - (1 - level) / 2)
  lower.perc <- (1 - level) / 2

  # internal function
  lower.lambda <- function(lambda) {
    (pchisq(X2, df = df, ncp = lambda) - upper.perc)
  }

  upper.lambda <- function(lambda) {
    (pchisq(X2, df = df, ncp = lambda) - lower.perc)
  }


  # lower bound
  if (df < 1 || lower.lambda(0) < 0.0) {
    rmsea.ci.lower <- 0
  } else {
    lambda.l <- try(uniroot(f = lower.lambda, lower = 0, upper = X2)$root,
      silent = TRUE
    )
    if (inherits(lambda.l, "try-error")) {
      lambda.l <- as.numeric(NA)
    }
    # lower bound
    rmsea.ci.lower <- sqrt((c.hat * lambda.l) / (N * df))

    # multiple groups? -> correction
    if (G > 1L) {
      rmsea.ci.lower <- rmsea.ci.lower * sqrt(G)
    }
  }

  # upper bound
  N.RMSEA <- max(N, X2 * 4)
  if (df < 1 || upper.lambda(N.RMSEA) > 0 || upper.lambda(0) < 0) {
    rmsea.ci.upper <- 0
  } else {
    lambda.u <- try(
      uniroot(
        f = upper.lambda, lower = 0,
        upper = N.RMSEA
      )$root,
      silent = TRUE
    )
    if (inherits(lambda.u, "try-error")) {
      lambda.u <- NA
    }
    # upper bound
    rmsea.ci.upper <- sqrt((c.hat * lambda.u) / (N * df))

    # multiple groups? -> correction
    if (G > 1L) {
      rmsea.ci.upper <- rmsea.ci.upper * sqrt(G)
    }
  }

  list(
    rmsea.ci.lower = rmsea.ci.lower,
    rmsea.ci.upper = rmsea.ci.upper
  )
}

# H_0: RMSEA <= rmsea.h0
lav_fit_rmsea_closefit <- function(X2 = NULL, df = NULL, N = NULL,
                                   G = 1L, c.hat = 1, rmsea.h0 = 0.05) {
  if (missing(N) || missing(X2) || missing(df) ||
    !is.finite(X2) || !is.finite(df) || !is.finite(N)) {
    return(as.numeric(NA))
  }

  rmsea.pvalue <- as.numeric(NA)
  if (df > 0) {
    # see Dudgeon 2004, eq 16 for the 'G' correction
    ncp <- (N * df * 1 / c.hat * rmsea.h0^2) / G
    rmsea.pvalue <- 1 - pchisq(X2, df = df, ncp = ncp)
  }

  rmsea.pvalue
}

# MacCallum, R. C., Browne, M. W., & Sugawara, H. M. (1996).
# H_0: RMSEA >= rmsea.h0
lav_fit_rmsea_notclosefit <- function(X2 = NULL, df = NULL, N = NULL,
                                      G = 1L, c.hat = 1, rmsea.h0 = 0.05) {
  if (missing(N) || missing(X2) || missing(df) ||
    !is.finite(X2) || !is.finite(df) || !is.finite(N)) {
    return(as.numeric(NA))
  }

  rmsea.pvalue <- as.numeric(NA)
  if (df > 0) {
    # see Dudgeon 2004, eq 16 for the 'G' correction
    ncp <- (N * df * 1 / c.hat * rmsea.h0^2) / G
    rmsea.pvalue <- pchisq(X2, df = df, ncp = ncp)
  }

  rmsea.pvalue
}


lav_fit_rmsea_lavobject <- function(lavobject = NULL, fit.measures = "rmsea",
                                    standard.test = "standard",
                                    scaled.test = "none",
                                    ci.level = 0.90,
                                    close.h0 = 0.05, notclose.h0 = 0.08,
                                    robust = TRUE,
                                    cat.check.pd = TRUE) {
  # check lavobject
  stopifnot(inherits(lavobject, "lavaan"))

  # check for categorical
  categorical.flag <- lavobject@Model@categorical

  # tests
  TEST <- lavobject@test
  test.names <- sapply(lavobject@test, "[[", "test")
  if (test.names[1] == "none" || standard.test == "none") {
    return(list())
  }
  test.idx <- which(test.names == standard.test)[1]
  if (length(test.idx) == 0L) {
    return(list())
  }

  scaled.flag <- FALSE
  if (!scaled.test %in% c("none", "standard", "default")) {
    scaled.idx <- which(test.names == scaled.test)
    if (length(scaled.idx) > 0L) {
      scaled.idx <- scaled.idx[1] # only the first one
      scaled.flag <- TRUE
    }
  }

  # robust?
  robust.flag <- FALSE
  if (robust && scaled.flag &&
    scaled.test %in% c(
      "satorra.bentler", "yuan.bentler.mplus",
      "yuan.bentler", "scaled.shifted"
    )) {
    robust.flag <- TRUE
  }

  # FIML?
  fiml.flag <- FALSE
  if (robust && lavobject@Options$missing %in% c("ml", "ml.x")) {
    fiml.flag <- robust.flag <- TRUE
    # check if we can compute corrected values
    if (scaled.flag) {
      version <- "V3"
    } else {
      version <- "V6"
    }
    fiml <- try(
      lav_fit_fiml_corrected(lavobject,
        baseline.model = NULL,
        version = version
      ),
      silent = TRUE
    )
    if (inherits(fiml, "try-error")) {
      lav_msg_warn(gettext("computation of robust RMSEA failed."))
      fiml <- list(
        XX3 = as.numeric(NA), df3 = as.numeric(NA),
        c.hat3 = as.numeric(NA), XX3.scaled = as.numeric(NA)
      )
    } else if (anyNA(c(fiml$XX3, fiml$df3, fiml$c.hat3, fiml$XX3.scaled))) {
      lav_msg_warn(gettext(
        "computation of robust RMSEA resulted in NA values."
      ))
    }
  }

  # supported fit measures in this function
  fit.rmsea <- c(
    "rmsea",
    "rmsea.ci.lower", "rmsea.ci.upper", "rmsea.ci.level",
    "rmsea.pvalue", "rmsea.close.h0",
    "rmsea.notclose.pvalue", "rmsea.notclose.h0"
  )
  if (scaled.flag) {
    fit.rmsea <- c(
      fit.rmsea, "rmsea.scaled", "rmsea.ci.lower.scaled",
      "rmsea.ci.upper.scaled", "rmsea.pvalue.scaled",
      "rmsea.notclose.pvalue.scaled"
    )
  }
  if (robust.flag) {
    fit.rmsea <- c(
      fit.rmsea, "rmsea.robust", "rmsea.ci.lower.robust",
      "rmsea.ci.upper.robust", "rmsea.pvalue.robust",
      "rmsea.notclose.pvalue.robust"
    )
  }

  # which one do we need?
  if (missing(fit.measures)) {
    # default set
    fit.measures <- fit.rmsea
  } else {
    # remove any not-RMSEA related index from fit.measures
    rm.idx <- which(!fit.measures %in% fit.rmsea)
    if (length(rm.idx) > 0L) {
      fit.measures <- fit.measures[-rm.idx]
    }
    if (length(fit.measures) == 0L) {
      return(list())
    }
  }


  # basic test statistics
  X2 <- TEST[[test.idx]]$stat
  df <- TEST[[test.idx]]$df
  G <- lavobject@Data@ngroups # number of groups
  N <- lav_object_inspect_ntotal(object = lavobject) # N vs N-1

  # scaled X2/df values
  if (scaled.flag) {
    if (scaled.test == "scaled.shifted") {
      XX2 <- TEST[[scaled.idx]]$stat
      df2 <- df
    } else {
      XX2 <- X2
      df2 <- sum(TEST[[scaled.idx]]$trace.UGamma)
      if (!is.finite(df2) || df2 == 0) {
        df2 <- as.numeric(NA)
      }
    }
  }

  # robust ingredients
  if (robust.flag) {
    if (categorical.flag) {
      out <- try(lav_fit_catml_dwls(lavobject, check.pd = cat.check.pd),
        silent = TRUE
      )
      if (inherits(out, "try-error")) {
        XX3 <- df3 <- c.hat3 <- XX3.scaled <- as.numeric(NA)
      } else {
        XX3 <- out$XX3
        df3 <- out$df3
        c.hat3 <- c.hat <- out$c.hat3
        XX3.scaled <- out$XX3.scaled
      }
    } else if (fiml.flag) {
      XX3 <- fiml$XX3
      df3 <- fiml$df3
      c.hat3 <- c.hat <- fiml$c.hat3
      XX3.scaled <- fiml$XX3.scaled
    } else {
      XX3 <- X2
      df3 <- df
      c.hat <- TEST[[scaled.idx]]$scaling.factor
      if (scaled.test == "scaled.shifted") {
        # compute c.hat from a and b
        a <- TEST[[scaled.idx]]$scaling.factor
        b <- TEST[[scaled.idx]]$shift.parameter
        c.hat3 <- a * (df - b) / df
      } else {
        c.hat3 <- c.hat
      }
      XX3.scaled <- TEST[[scaled.idx]]$stat
    }
  }

  # output container
  indices <- list()

  # what do we need?
  rmsea.val.flag <- rmsea.ci.flag <- rmsea.pvalue.flag <- FALSE
  if (any(c("rmsea", "rmsea.scaled", "rmsea.robust") %in% fit.measures)) {
    rmsea.val.flag <- TRUE
  }
  if (any(c(
    "rmsea.ci.lower", "rmsea.ci.upper", "rmsea.ci.level",
    "rmsea.ci.lower.scaled", "rmsea.ci.upper.scaled",
    "rmsea.ci.lower.robust", "rmsea.ci.upper.robust"
  )
  %in% fit.measures)) {
    rmsea.ci.flag <- TRUE
  }
  if (any(c(
    "rmsea.pvalue", "rmsea.pvalue.scaled", "rmsea.pvalue.robust",
    "rmsea.notclose.pvalue", "rmsea.notclose.pvalue.scaled",
    "rmsea.notclose.pvalue.robust",
    "rmsea.close.h0", "rmsea.notclose.h0"
  )
  %in% fit.measures)) {
    rmsea.pvalue.flag <- TRUE
  }


  # 1. RMSEA
  if (rmsea.val.flag) {
    indices["rmsea"] <- lav_fit_rmsea(X2 = X2, df = df, N = N, G = G)
    if (scaled.flag) {
      indices["rmsea.scaled"] <- lav_fit_rmsea(
        X2 = XX2, df = df2,
        N = N, G = G
      )
    }
    if (robust.flag) {
      indices["rmsea.robust"] <-
        lav_fit_rmsea(X2 = XX3, df = df3, N = N, c.hat = c.hat3, G = G)
    }
  }

  # 2. RMSEA CI
  if (rmsea.ci.flag) {
    indices["rmsea.ci.level"] <- ci.level
    ci <- lav_fit_rmsea_ci(X2 = X2, df = df, N = N, G = G, level = ci.level)
    indices["rmsea.ci.lower"] <- ci$rmsea.ci.lower
    indices["rmsea.ci.upper"] <- ci$rmsea.ci.upper

    if (scaled.flag) {
      ci.scaled <- lav_fit_rmsea_ci(
        X2 = XX2, df = df2, N = N, G = G,
        level = ci.level
      )
      indices["rmsea.ci.lower.scaled"] <- ci.scaled$rmsea.ci.lower
      indices["rmsea.ci.upper.scaled"] <- ci.scaled$rmsea.ci.upper
    }
    if (robust.flag) {
      # note: input is scaled test statistic!
      ci.robust <- lav_fit_rmsea_ci(
        X2 = XX3.scaled,
        df = df3, N = N, G = G, c.hat = c.hat,
        level = ci.level
      )
      indices["rmsea.ci.lower.robust"] <- ci.robust$rmsea.ci.lower
      indices["rmsea.ci.upper.robust"] <- ci.robust$rmsea.ci.upper
    }
  }

  # 3. RMSEA pvalue
  if (rmsea.pvalue.flag) {
    indices["rmsea.close.h0"] <- close.h0
    indices["rmsea.notclose.h0"] <- notclose.h0
    indices["rmsea.pvalue"] <-
      lav_fit_rmsea_closefit(
        X2 = X2, df = df, N = N, G = G,
        rmsea.h0 = close.h0
      )
    indices["rmsea.notclose.pvalue"] <-
      lav_fit_rmsea_notclosefit(
        X2 = X2, df = df, N = N, G = G,
        rmsea.h0 = notclose.h0
      )
    if (scaled.flag) {
      indices["rmsea.pvalue.scaled"] <-
        lav_fit_rmsea_closefit(
          X2 = XX2, df = df2, N = N, G = G,
          rmsea.h0 = close.h0
        )
      indices["rmsea.notclose.pvalue.scaled"] <-
        lav_fit_rmsea_notclosefit(
          X2 = XX2, df = df2, N = N, G = G,
          rmsea.h0 = notclose.h0
        )
    }
    if (robust.flag) {
      indices["rmsea.pvalue.robust"] <- # new in 0.6-13
        lav_fit_rmsea_closefit(
          X2 = XX3.scaled,
          df = df3,
          N = N, G = G, c.hat = c.hat,
          rmsea.h0 = close.h0
        )
      indices["rmsea.notclose.pvalue.robust"] <- # new in 0.6-13
        lav_fit_rmsea_notclosefit(
          X2 = XX3.scaled,
          df = df3,
          N = N, G = G, c.hat = c.hat,
          rmsea.h0 = notclose.h0
        )
    }
  }

  # return only those that were requested
  indices[fit.measures]
}

# contributed by Myrsini Katsikatsou (March 2016)

# the function lav_pml_bi_lik_x gives the value of the bivariate likelihood
# for a specific pair of ordinal variables casewise when covariates are present and estimator=="PML"
# (the bivariate likelihood is essentially the bivariate probability of the
# observed response pattern of two ordinal variables)

# Input arguments:
# Y1 is a vector, includes the observed values for the first variable for all cases/units,
# Y1 is ordinal
# Y2 similar to Y1
# Rho is the polychoric correlation of Y1 and Y2
# th.y1 is the vector of the thresholds for Y1* excluding the first and
# the last thresholds which are -Inf and Inf
# th.y2 is similar to th.y1
# eXo is the data for the covariates in a matrix format where nrows= no of cases,
# ncols= no of covariates
# PI.y1 is a vector, includes the regression coefficients of the covariates
# for the first variable, Y1, the length of the vector is the no of covariates;
# to obtain this vector apply the function lavaan:::lav_model_pi()[row_correspondin_to_Y1, ]
# PI.y2 is similar to PI.y2
# missing.ind is of "character" value, taking the values listwise, pairwise, available_cases;
# to obtain a value use lavdata@missing

# Output:
# It is a vector, length= no of cases, giving the bivariate likelihood for each case.
lav_pml_bi_lik_x <- function(Y1, Y2, Rho,
                               th.y1, th.y2,
                               eXo,
                               PI.y1, PI.y2,
                               missing.ind) {
  th.y1 <- c(-100, th.y1, 100)
  th.y2 <- c(-100, th.y2, 100)
  pred.y1 <- c(eXo %*% PI.y1)
  pred.y2 <- c(eXo %*% PI.y2)

  th.y1.upper <- th.y1[Y1 + 1L] - pred.y1
  th.y1.lower <- th.y1[Y1] - pred.y1
  th.y2.upper <- th.y2[Y2 + 1L] - pred.y2
  th.y2.lower <- th.y2[Y2] - pred.y2

  if (missing.ind == "listwise") { # I guess this is the default which
    # also handles the case of complete data
    biv_prob <- pbivnorm(th.y1.upper, th.y2.upper, rho = Rho) -
      pbivnorm(th.y1.lower, th.y2.upper, rho = Rho) -
      pbivnorm(th.y1.upper, th.y2.lower, rho = Rho) +
      pbivnorm(th.y1.lower, th.y2.lower, rho = Rho)
    lik <- biv_prob
  } else if (missing.ind %in% c(
    "pairwise",
    "available.cases",
    "available_cases"
  )) {
    # index of cases with complete pairs
    CP.idx <- which(complete.cases(cbind(Y1, Y2)))

    th.y1.upper <- th.y1.upper[CP.idx]
    th.y1.lower <- th.y1.lower[CP.idx]
    th.y2.upper <- th.y2.upper[CP.idx]
    th.y2.lower <- th.y2.lower[CP.idx]

    biv_prob <- pbivnorm(th.y1.upper, th.y2.upper, rho = Rho) -
      pbivnorm(th.y1.lower, th.y2.upper, rho = Rho) -
      pbivnorm(th.y1.upper, th.y2.lower, rho = Rho) +
      pbivnorm(th.y1.lower, th.y2.lower, rho = Rho)

    # lik <- numeric( length(Y1) )
    lik <- rep(as.numeric(NA), length(Y1))
    lik[CP.idx] <- biv_prob
  }
  lik
}

#################################################################


# The function  lav_pml_uni_lik gives the value of the univariate likelihood for a
# specific ordinal variable, casewise (which is essentially the probability for
# the observed response category for each case).
# The input arguments are explained before the function lav_pml_bi_lik_x above.
# Output:
# It is a vector, length= no of cases, giving the univariate likelihoods for each case.

lav_pml_uni_lik <- function(Y1, th.y1, eXo = NULL, PI.y1 = NULL) {
  th.y1 <- c(-100, th.y1, 100)
  if (!is.null(eXo)) {
    pred.y1 <- c(eXo %*% PI.y1)
  }

  if (is.null(eXo)) {
    th.y1.upper <- th.y1[Y1 + 1L]
    th.y1.lower <- th.y1[Y1]
  } else {
    th.y1.upper <- th.y1[Y1 + 1L] - pred.y1
    th.y1.lower <- th.y1[Y1] - pred.y1
  }

  lav_pml_uni_lik <- pnorm(th.y1.upper) - pnorm(th.y1.lower)

  lav_pml_uni_lik[is.na(lav_pml_uni_lik)] <- 0

  lav_pml_uni_lik
}

#################################################################

# The function lav_pml_th_uni_prob gives the model-based univariate probabilities
# for all ordinal indicators and for all of their response categories, i.e. pi(xi=a), where
# a=1,...,ci and i=1,...,p with a index running faster than i index.
# Input arguments:
# TH is a vector giving the thresholds for all variables, tau_ia, with a running
#    faster than i (the first and the last thresholds which are -Inf and Inf are
#    not included). TH can be given by the lavaan function lav_model_th .
# th.idx is a vector of same length as TH which gives the value of the i index,
#        namely which variable each thresholds refers to. This can be obtained by
#        lavmodel@th.idx .
# Output:
# It is a vector, lenght= Sum_i(ci), i.e. the sum of the response categories of
# all ordinal variables. The vector contains the model-based univariate probabilities pi(xi=a).

lav_pml_th_uni_prob <- function(TH = TH, th.idx = th.idx) {
  TH.split <- split(TH, th.idx)
  TH.lower <- unlist(lapply(TH.split, function(x) {
    c(-100, x)
  }), use.names = FALSE)
  TH.upper <- unlist(lapply(TH.split, function(x) {
    c(x, 100)
  }), use.names = FALSE)
  prob <- pnorm(TH.upper) - pnorm(TH.lower)
  # to avoid Nan/-Inf
  prob[prob < .Machine$double.eps] <- .Machine$double.eps
  prob
}

#############################################################################


# The function lav_pml_dbilogl_dpar_x computes the derivatives of a bivariate
# log-likelihood of two ordinal variables casewise with respect to thresholds,
# slopes (reduced-form regression coefficients for the covariates), and polychoric correlation.
# The function lav_dbinorm of lavaan is used.
# The function gives the right result for both listwise and pairwise deletion,
# and the case of complete data.
# Input arguments are explained before the function lav_pml_bi_lik_x defined above.
# The only difference is that PI.y1 and PI.y2 are (accidentally) renamed here as sl.y1 and sl.y2
# Output:
# It is a list containing the following
# a) the derivatives w.r.t. the thresholds of the first variable casewise.
#    This is a matrix, nrows=no of cases, ncols= no of thresholds of variable 1.
# b) the derivatives w.r.t. the thresholds of the second variable casewise.
#    This is a matrix, nrows=no of cases, ncols= no of thresholds of variable 2.
# c) the derivatives w.r.t slopes for variable 1.  This is a matrix, where
#    nrows=no of cases, ncols= no of covariates.
# d) the derivatives w.r.t slopes for variable 2.  This is a matrix, where
#    nrows=no of cases, ncols= no of covariates.
# e) the derivative w.r.t the polychoric correlation of the two variables.
#    This is a vector of length= no of cases.


lav_pml_dbilogl_dpar_x <- function(Y1, Y2, eXo, Rho,
                                      th.y1, th.y2,
                                      sl.y1, sl.y2,
                                      missing.ind) {
  nth.y1 <- length(th.y1)
  nth.y2 <- length(th.y2)

  start.th.y1 <- th.y1
  start.th.y2 <- th.y2

  Nobs <- length(Y1)

  R <- sqrt(1 - Rho * Rho)
  th.y1 <- c(-100, th.y1, 100)
  th.y2 <- c(-100, th.y2, 100)
  pred.y1 <- c(eXo %*% sl.y1)
  pred.y2 <- c(eXo %*% sl.y2)

  th.y1.z1 <- th.y1[Y1 + 1L] - pred.y1
  th.y1.z2 <- th.y1[Y1] - pred.y1
  th.y2.z1 <- th.y2[Y2 + 1L] - pred.y2
  th.y2.z2 <- th.y2[Y2] - pred.y2

  # lik, i.e. the bivariate probability case-wise
  lik <- lav_pml_bi_lik_x(
    Y1 = Y1, Y2 = Y2,
    Rho = Rho,
    th.y1 = start.th.y1,
    th.y2 = start.th.y2,
    eXo = eXo,
    PI.y1 = sl.y1,
    PI.y2 = sl.y2,
    missing.ind = missing.ind
  )


  # w.r.t. th.y1, mean tau tilde
  # derivarive bivariate prob w.r.t. tau^xi_ci, see formula in paper 2012
  y1.Z1 <- dnorm(th.y1.z1) * (pnorm((th.y2.z1 - Rho * th.y1.z1) / R) -
    pnorm((th.y2.z2 - Rho * th.y1.z1) / R))
  # derivarive bivariate prob w.r.t. tau^xi_(ci-1),
  y1.Z2 <- (-1) * (dnorm(th.y1.z2) * (pnorm((th.y2.z1 - Rho * th.y1.z2) / R) -
    pnorm((th.y2.z2 - Rho * th.y1.z2) / R)))


  # allocate the derivatives at the right column casewise
  idx.y1.z1 <- matrix(1:nth.y1, nrow = Nobs, ncol = nth.y1, byrow = TRUE) == Y1
  idx.y1.z2 <- matrix(1:nth.y1, nrow = Nobs, ncol = nth.y1, byrow = TRUE) == (Y1 - 1L)
  der.table.y1 <- idx.y1.z1 * y1.Z1 + idx.y1.z2 * y1.Z2

  # der of pl w.r.t. th.y1
  dx.th.tilde.y1 <- der.table.y1 / lik
  dx.th.tilde.y1[is.na(dx.th.tilde.y1)] <- 0

  # w.r.t. th.y2, mean tau tilde
  # derivarive bivariate prob w.r.t. tau^xi_ci, see formula in paper 2012
  y2.Z1 <- dnorm(th.y2.z1) * (pnorm((th.y1.z1 - Rho * th.y2.z1) / R) -
    pnorm((th.y1.z2 - Rho * th.y2.z1) / R))
  # derivarive bivariate prob w.r.t. tau^xi_(ci-1),
  y2.Z2 <- (-1) * (dnorm(th.y2.z2) * (pnorm((th.y1.z1 - Rho * th.y2.z2) / R) -
    pnorm((th.y1.z2 - Rho * th.y2.z2) / R)))
  # allocate the derivatives at the right column casewise
  idx.y2.z1 <- matrix(1:nth.y2, nrow = Nobs, ncol = nth.y2, byrow = TRUE) == Y2
  idx.y2.z2 <- matrix(1:nth.y2, nrow = Nobs, ncol = nth.y2, byrow = TRUE) == (Y2 - 1L)
  der.table.y2 <- idx.y2.z1 * y2.Z1 + idx.y2.z2 * y2.Z2

  # der of pl w.r.t. th.y2
  dx.th.tilde.y2 <- der.table.y2 / lik
  dx.th.tilde.y2[is.na(dx.th.tilde.y2)] <- 0



  # w.r.t. rho
  # derivarive bivariate prob w.r.t. rho, see formula in paper 2012
  dbivprob.wrt.rho <- (lav_dbinorm(th.y1.z1, th.y2.z1, Rho) -
    lav_dbinorm(th.y1.z2, th.y2.z1, Rho) -
    lav_dbinorm(th.y1.z1, th.y2.z2, Rho) +
    lav_dbinorm(th.y1.z2, th.y2.z2, Rho))
  # der of pl w.r.t. rho
  dx.rho <- dbivprob.wrt.rho / lik
  dx.rho[is.na(dx.rho)] <- 0


  # der of pl w.r.t. slopes (also referred to PI obtained by lav_model_pi function)
  row.sums.y1 <- rowSums(dx.th.tilde.y1)
  row.sums.y2 <- rowSums(dx.th.tilde.y2)
  dx.sl.y1 <- (-1) * eXo * row.sums.y1
  dx.sl.y2 <- (-1) * eXo * row.sums.y2


  list(
    dx.th.y1 = dx.th.tilde.y1, # note that dx.th.tilde=dx.th
    dx.th.y2 = dx.th.tilde.y2,
    dx.sl.y1 = dx.sl.y1,
    dx.sl.y2 = dx.sl.y2,
    dx.rho = dx.rho
  )
}

###############################################################


# The function lav_pml_uni_scores gives, casewise, the derivative of a univariate
# log-likelihood w.r.t. thresholds and slopes if present weighted by the
# casewise uni-weights as those defined in AC-PL (essentially the number of missing values per case).
# The function closely follows the "logic" of the function lav_pml_dbilogl_dpar_x defined above.
# Input arguments are as before plus: weights.casewise given by
# lavcavhe$uniweights.casewise .
# Output:
# A list including the following:
# a) the derivatives w.r.t. the thresholds of the variable. This is a matrix,
#    nrows=no of cases, ncols= no of thresholds of variable 1.
# b) the derivatives w.r.t slopes for the variable. If covariates are present,
#    this is a matrix, nrows=no of cases, ncols= no of covariates.
#    Otherwise it takes the value NULL.


lav_pml_uni_scores <- function(Y1, th.y1, eXo = NULL, sl.y1 = NULL,
                       weights.casewise) {
  nth.y1 <- length(th.y1)
  start.th.y1 <- th.y1
  Nobs <- length(Y1)
  th.y1 <- c(-100, th.y1, 100)

  if (is.null(eXo)) {
    th.y1.z1 <- th.y1[Y1 + 1L]
    th.y1.z2 <- th.y1[Y1]
  } else {
    pred.y1 <- c(eXo %*% sl.y1)
    th.y1.z1 <- th.y1[Y1 + 1L] - pred.y1
    th.y1.z2 <- th.y1[Y1] - pred.y1
  }

  # lik, i.e. the univariate probability case-wise
  lik <- lav_pml_uni_lik( # Y1 = X[,i],
    Y1 = Y1,
    # th.y1 = TH[th.idx==i],
    th.y1 = th.y1,
    eXo = eXo,
    # PI.y1 = PI[i,])
    PI.y1 = sl.y1
  )

  # w.r.t. th.y1
  # derivarive of the univariate prob w.r.t. to the upper limit threshold
  y1.Z1 <- dnorm(th.y1.z1)
  # derivarive of the univariate prob w.r.t. to the lower limit threshold
  y1.Z2 <- (-1) * dnorm(th.y1.z2)

  # allocate the derivatives at the right column casewise
  idx.y1.z1 <- matrix(1:nth.y1, nrow = Nobs, ncol = nth.y1, byrow = TRUE) == Y1
  idx.y1.z2 <- matrix(1:nth.y1, nrow = Nobs, ncol = nth.y1, byrow = TRUE) == (Y1 - 1L)
  der.table.y1 <- idx.y1.z1 * y1.Z1 + idx.y1.z2 * y1.Z2

  # der of pl w.r.t. th.y1
  dx.th.tilde.y1 <- der.table.y1 * (weights.casewise / lik)
  dx.th.tilde.y1[is.na(dx.th.tilde.y1)] <- 0

  # der of pl w.r.t. slopes (also referred to PI obtained by lav_model_pi function)
  dx.sl.y1 <- NULL
  if (!is.null(eXo)) {
    row.sums.y1 <- rowSums(dx.th.tilde.y1)
    dx.sl.y1 <- (-1) * eXo * row.sums.y1
  }

  list(
    dx.th.y1 = dx.th.tilde.y1, # note that dx.th.tilde=dx.th
    dx.sl.y1 = dx.sl.y1
  )
}

# a partial implementation of the Bentler (1982) non-iterative method for CFA
#
# Bentler, P. M. (1982). Confirmatory factor-analysis via noniterative
# estimation - a fast, inexpensive method. Journal of Marketing Research,
# 19(4), 417-424. https://doi.org/10.1177/002224378201900403
#
#
# YR 03 Feb 2023: - first version in lavaan: simple setting only,
#                   no constraints, no 'fixed' (but nonzero) values,
#                   no correlated residuals (ie diagonal-theta only!)
# YR 23 Apr 2023: - quadprog is not needed if we have no (in)equality
#                   constraints

lav_cfa_bentler1982 <- function(S,
                                marker.idx = NULL,
                                lambda.nonzero.idx = NULL,
                                GLS = FALSE,
                                bounds = TRUE,
                                min.reliability.marker = 0.1,
                                quadprog = FALSE,
                                nobs = 20L) { # for cutoff
  # dimensions
  nvar <- ncol(S)
  nfac <- length(marker.idx)

  # lambda structure
  B <- matrix(0, nvar, nfac)
  lambda.marker.idx <- (seq_len(nfac) - 1L) * nvar + marker.idx
  B[lambda.marker.idx] <- 1L
  B[lambda.nonzero.idx] <- 1L

  # partition sample covariance matrix: marker vs non-marker
  S.xx <- S[marker.idx, marker.idx, drop = FALSE]
  S.yx <- S[-marker.idx, marker.idx, drop = FALSE]
  S.xy <- S[marker.idx, -marker.idx, drop = FALSE]
  S.yy <- S[-marker.idx, -marker.idx, drop = FALSE]
  p <- nvar - nfac
  B.y <- B[-marker.idx, , drop = FALSE]

  # check for p = 0?

  # phase 1: initial estimate for Sigma.yx
  Sigma.yx.hat <- S.yx

  # phase 2: using GLS/ULS to obtain PSI and Theta
  if (GLS) {
    W <- try(solve(S.yy), silent = TRUE)
    if (inherits(W, "try-error")) {
      lav_msg_warn(gettext("could not inverte S.yy; switching to ULS"))
      W <- diag(p)
    }
    WS.yx <- W %*% S.yx
    xy.SWS.yx <- crossprod(S.yx, WS.yx)
    G <- WS.yx %*% solve(xy.SWS.yx) %*% t(WS.yx)
  } else {
    Ip <- diag(p)
    xy.SS.yx <- crossprod(S.yx)
    G <- S.yx %*% solve(xy.SS.yx) %*% t(S.yx)
  }

  # only needed if theta.y is not diagonal:
  # q <- 6 # all free
  # # dimension P: q x p*p where q is the number of free elements theta.y
  # theta.fy <- function(x) {
  #     theta.y <- matrix(0, p, p)
  #     # insert 'free' parameters only
  #     diag(theta.y) <- x
  #     lav_matrix_vec(theta.y)
  # }
  # P <- t(numDeriv::jacobian(func = theta.fy, x = rep(1, q)))

  # tmp1 <- P %*% ((W %x% W) - (G %x% G)) %*% t(P)
  # NOTE:
  # if only the 'diagonal' element of Theta are free (as usual), then we
  # can write tmp1 as
  if (GLS) {
    tmp1 <- W * W - G * G
  } else {
    tmp1 <- Ip - G * G
  }

  # only needed if fixed values
  # Theta.F <- matrix(0, p, p) # all free
  # tmp2 <- W %*% (S.yy - Theta.F) %*% W - G %*% (S.yy - Theta.F) %*% G
  if (GLS) {
    tmp2 <- W %*% S.yy %*% W - G %*% S.yy %*% G
  } else {
    tmp2 <- S.yy - G %*% S.yy %*% G
  }

  # Theta.f    <- as.numeric(solve(tmp1) %*% P %*% lav_matrix_vec(tmp2))
  # Note:
  # if only the 'diagonal' element of Theta are free (as usual), then we
  # can write Theta.f as
  Theta.f <- solve(tmp1, diag(tmp2))
  Theta.f.nobounds <- Theta.f # store unbounded Theta.f values

  # ALWAYS apply standard bounds to proceed
  too.small.idx <- which(Theta.f < 0)
  if (length(too.small.idx) > 0L) {
    Theta.f[too.small.idx] <- 0
  }
  too.large.idx <- which(Theta.f > diag(S.yy))
  if (length(too.large.idx) > 0L) {
    Theta.f[too.large.idx] <- diag(S.yy)[too.large.idx] * 1
  }

  # create diagonal matrix with Theta.f elements on diagonal
  Theta.yhat <- diag(Theta.f, p)

  # force (S.yy - Theta.yhat) to be positive definite
  lambda <- try(lav_matrix_symmetric_diff_smallest_root(S.yy, Theta.yhat),
    silent = TRUE
  )
  if (inherits(lambda, "try-error")) {
    lav_msg_warn(gettext("failed to compute lambda"))
    SminTheta <- S.yy - Theta.yhat # and hope for the best
  } else {
    cutoff <- 1 + 1 / (nobs - 1)
    if (lambda < cutoff) {
      lambda.star <- lambda - 1 / (nobs - 1)
      SminTheta <- S.yy - lambda.star * Theta.yhat
    } else {
      SminTheta <- S.yy - Theta.yhat
    }
  }

  # estimate Phi
  if (GLS) {
    tmp1 <- xy.SWS.yx
    tmp2 <- t(WS.yx) %*% SminTheta %*% WS.yx
  } else {
    tmp1 <- xy.SS.yx
    tmp2 <- t(S.yx) %*% SminTheta %*% S.yx
  }
  PSI <- tmp1 %*% solve(tmp2, tmp1)
  PSI.nobounds <- PSI

  # ALWAYS apply bounds to proceed
  lower.bounds.psi <- diag(S.xx) - (1 - min.reliability.marker) * diag(S.xx)
  toolow.idx <- which(diag(PSI) < lower.bounds.psi)
  if (length(toolow.idx) > 0L) {
    diag(PSI)[toolow.idx] <- lower.bounds.psi[toolow.idx]
  }
  too.large.idx <- which(diag(PSI) > diag(S.xx))
  if (length(too.large.idx) > 0L) {
    diag(PSI)[too.large.idx] <- diag(S.xx)[too.large.idx] * 1
  }

  # in addition, force PSI to be PD
  PSI <- lav_matrix_symmetric_force_pd(PSI, tol = 1e-04)

  # residual variances markers
  Theta.x <- diag(S.xx - PSI)

  # create theta vector
  theta.nobounds <- numeric(nvar)
  theta.nobounds[marker.idx] <- Theta.x
  theta.nobounds[-marker.idx] <- Theta.f.nobounds

  # compute LAMBDA for non-marker items

  if (quadprog) {
    # only really needed if we need to impose (in)equality constraints
    # (TODO)
    Dmat <- lav_matrix_bdiag(rep(list(PSI), p))
    dvec <- as.vector(t(S.yx))
    eq.idx <- which(t(B.y) != 1) # these must be zero (row-wise!)
    Rmat <- diag(nrow(Dmat))[eq.idx, , drop = FALSE]
    bvec <- rep(0, length(eq.idx)) # optional, 0=default
    out <- try(quadprog::solve.QP(
      Dmat = Dmat, dvec = dvec, Amat = t(Rmat),
      meq = length(eq.idx), bvec = bvec
    ), silent = TRUE)
    if (inherits(out, "try-error")) {
      lav_msg_warn(gettext("solve.QP failed to find a solution"))
      Lambda <- matrix(0, nvar, nfac)
      Lambda[marker.idx, ] <- diag(nfac)
      Lambda[lambda.nonzero.idx] <- as.numeric(NA)
      Theta <- numeric(nvar)
      Theta[marker.idx] <- Theta.x
      Theta[-marker.idx] <- Theta.f
      Psi <- PSI
      return(list(
        lambda = Lambda, theta = theta.nobounds,
        psi = PSI.nobounds
      ))
    } else {
      LAMBDA.y <- matrix(out$solution,
        nrow = p, ncol = nfac,
        byrow = TRUE
      )
      # zap almost zero elements
      LAMBDA.y[abs(LAMBDA.y) < sqrt(.Machine$double.eps)] <- 0
    }
  } else {
    # simple version
    #LAMBDA.y <- t(t(S.yx) / diag(PSI)) * B.y # works only if no crossloadings
    LAMBDA.y <- t(solve(PSI, t(S.yx))) * B.y
  }


  # assemble matrices
  LAMBDA <- matrix(0, nvar, nfac)
  LAMBDA[marker.idx, ] <- diag(nfac)
  LAMBDA[-marker.idx, ] <- LAMBDA.y

  list(lambda = LAMBDA, theta = theta.nobounds, psi = PSI.nobounds)
}

# internal function to be used inside lav_optim_noniter
# return 'x', the estimated vector of free parameters
lav_cfa_bentler1982_internal <- function(lavobject = NULL, # convenience
                                         # internal slot
                                         lavmodel = NULL,
                                         lavsamplestats = NULL,
                                         lavpartable = NULL,
                                         lavdata = NULL,
                                         lavoptions = NULL,
                                         GLS = TRUE,
                                         min.reliability.marker = 0.1,
                                         quadprog = FALSE,
                                         nobs = 20L) {
  lavpta <- NULL
  if (!is.null(lavobject)) {
    stopifnot(inherits(lavobject, "lavaan"))
    # extract slots
    lavmodel <- lavobject@Model
    lavsamplestats <- lavobject@SampleStats
    lavpartable <- lav_partable_set_cache(lavobject@ParTable, lavobject@pta)
    lavpta <- lavobject@pta
    lavdata <- lavobject@Data
    lavoptions <- lavobject@Options
  }
  if (is.null(lavpta)) {
    lavpta <- lav_partable_attributes(lavpartable)
    lavpartable <- lav_partable_set_cache(lavpartable, lavpta)
  }
  # no structural part!
  if (any(lavpartable$op == "~")) {
    lav_msg_stop(gettext("bentler1982 estimator only available for CFA models"))
  }
  # no BETA matrix! (i.e., no higher-order factors)
  if (!is.null(lavmodel@GLIST$beta)) {
    lav_msg_stop(gettext("bentler1982 estimator not available
                 for models that require a BETA matrix"))
  }
  # no std.lv = TRUE for now
  if (lavoptions$std.lv) {
    lav_msg_stop(gettext(
      "bentler1982 estimator not available if std.lv = TRUE"))
  }

  nblocks <- lav_partable_nblocks(lavpartable)
  stopifnot(nblocks == 1L) # for now
  b <- 1L
  sample.cov <- lavsamplestats@cov[[b]]
  nvar <- nrow(sample.cov)
  lv.names <- lavpta$vnames$lv.regular[[b]]
  nfac <- length(lv.names)
  marker.idx <- lavpta$vidx$lv.marker[[b]]
  lambda.idx <- which(names(lavmodel@GLIST) == "lambda")
  lambda.nonzero.idx <- lavmodel@m.free.idx[[lambda.idx]]
  # only diagonal THETA for now...
  # because if we have correlated residuals, we should remove the
  # corresponding variables as instruments before we estimate lambda...
  # (see MIIV)
  theta.idx <- which(names(lavmodel@GLIST) == "theta") # usually '2'
  m.theta <- lavmodel@m.free.idx[[theta.idx]]
  nondiag.idx <- m.theta[!m.theta %in% lav_matrix_diag_idx(nvar)]
  if (length(nondiag.idx) > 0L) {
    lav_msg_warn(gettext(
      "this implementation of FABIN does not handle correlated residuals yet!"))
  }

  if (!missing(GLS)) {
    GLS.flag <- GLS
  } else {
    GLS.flag <- FALSE
    if (!is.null(lavoptions$estimator.args$GLS) &&
      lavoptions$estimator.args$GLS) {
      GLS.flag <- TRUE
    }
  }

  if (missing(quadprog) &&
    !is.null(lavoptions$estimator.args$quadprog)) {
    quadprog <- lavoptions$estimator.args$quadprog
  }

  # run bentler1982 non-iterative CFA algorithm
  out <- lav_cfa_bentler1982(
    S = sample.cov, marker.idx = marker.idx,
    lambda.nonzero.idx = lambda.nonzero.idx,
    GLS = GLS.flag,
    min.reliability.marker = 0.1,
    quadprog = quadprog,
    nobs = lavsamplestats@ntotal
  )
  LAMBDA <- out$lambda
  THETA <- diag(out$theta, nvar)
  PSI <- out$psi

  # store matrices in lavmodel@GLIST
  lavmodel@GLIST$lambda <- LAMBDA
  lavmodel@GLIST$theta <- THETA
  lavmodel@GLIST$psi <- PSI

  # extract free parameters only
  x <- lav_model_get_parameters(lavmodel)

  # apply bounds (if any)
  if (!is.null(lavpartable$lower)) {
    lower.x <- lavpartable$lower[lavpartable$free > 0]
    too.small.idx <- which(x < lower.x)
    if (length(too.small.idx) > 0L) {
      x[too.small.idx] <- lower.x[too.small.idx]
    }
  }
  if (!is.null(lavpartable$upper)) {
    upper.x <- lavpartable$upper[lavpartable$free > 0]
    too.large.idx <- which(x > upper.x)
    if (length(too.large.idx) > 0L) {
      x[too.large.idx] <- upper.x[too.large.idx]
    }
  }

  x
}

# the information matrix of the unrestricted (H1) model
# taking into account:
#   - the estimator (ML or (D)WLS/ULS)
#   - missing or not
#   - fixed.x = TRUE or FALSE
#   - conditional.x = TRUE or FALSE
#   - h1.information is "structured" or "unstructured"
#
# Note: this replaces the (old) lav_model_wls_v() function
#
# - YR 22 Okt 2017: initial version
# - YR 03 Dec 2017: add lavh1, implied is either lavimplied or lavh1
#                   add support for clustered data: first.order
# - YR 03 Jan 2018: add support for clustered data: expected
# - YR 23 Aug 2018: lav_model_h1_acov (0.6-3)


## For the lavaan.mi package, TDJ provides pooled versions of all the
## sample moments called in these functions.  If any updates to these functions
## require NEW information (from @SampleStats or @implied or @h1),
## PLEASE ADD A TAG     @TDJorgensen
## at the end of the commit message on GitHub, so TDJ can check whether
## lavaan.mi::lavResiduals.mi() needs to be updated accordingly.



lav_model_h1_information <- function(lavobject = NULL,
                                     lavmodel = NULL,
                                     lavsamplestats = NULL,
                                     lavdata = NULL,
                                     lavimplied = NULL,
                                     lavh1 = NULL,
                                     lavcache = NULL,
                                     lavoptions = NULL) {
  if (!is.null(lavobject) && inherits(lavobject, "lavaan")) {
    lavmodel <- lavobject@Model
    lavsamplestats <- lavobject@SampleStats
    lavdata <- lavobject@Data
    lavimplied <- lavobject@implied
    lavh1 <- lavobject@h1
    lavcache <- lavobject@Cache
    lavoptions <- lavobject@Options
  }

  # sanity check
  if (length(lavh1) == 0L) {
    lavh1 <- lav_h1_implied_logl(
      lavdata = lavdata,
      lavsamplestats = lavsamplestats,
      lavoptions = lavoptions
    )
  }
  if (length(lavimplied) == 0L) {
    lavimplied <- lav_model_implied(lavmodel = lavmodel)
  }

  # information
  information <- lavoptions$information[1] # ALWAYS take the first one
  # the caller must control it


  # compute information matrix
  if (information == "observed") {
    I1 <- lav_model_h1_information_observed(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavimplied = lavimplied, lavh1 = lavh1,
      lavcache = lavcache, lavoptions = lavoptions
    )
  } else if (information == "expected") {
    I1 <- lav_model_h1_information_expected(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavimplied = lavimplied, lavh1 = lavh1,
      lavcache = lavcache, lavoptions = lavoptions
    )
  } else if (information == "first.order") {
    I1 <- lav_model_h1_information_firstorder(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavimplied = lavimplied, lavh1 = lavh1,
      lavcache = lavcache, lavoptions = lavoptions
    )
  }

  # I1 information, as a list per group
  I1
}

# fisher/expected information of H1
lav_model_h1_information_expected <- function(lavobject = NULL,
                                              lavmodel = NULL,
                                              lavsamplestats = NULL,
                                              lavdata = NULL,
                                              lavoptions = NULL,
                                              lavimplied = NULL,
                                              lavh1 = NULL,
                                              lavcache = NULL) {
  if (!is.null(lavobject) && inherits(lavobject, "lavaan")) {
    lavmodel <- lavobject@Model
    lavsamplestats <- lavobject@SampleStats
    lavdata <- lavobject@Data
    lavimplied <- lavobject@implied
    lavh1 <- lavobject@h1
    lavcache <- lavobject@Cache
    lavoptions <- lavobject@Options
  }

  # sanity check
  if (length(lavh1) == 0L) {
    lavh1 <- lav_h1_implied_logl(
      lavdata = lavdata,
      lavsamplestats = lavsamplestats,
      lavoptions = lavoptions
    )
  }
  if (length(lavimplied) == 0L) {
    lavimplied <- lav_model_implied(lavmodel = lavmodel)
  }

  estimator <- lavmodel@estimator

  # structured of unstructured? (since 0.5-23)
  if (!is.null(lavoptions) &&
    !is.null(lavoptions$h1.information[1]) &&
    lavoptions$h1.information[1] == "unstructured") {
    structured <- FALSE
  } else {
    structured <- TRUE
  }

  # 1. WLS.V (=A1) for GLS/WLS
  if (lavmodel@estimator == "GLS" || lavmodel@estimator == "WLS") {
    A1 <- lavsamplestats@WLS.V
  }

  # 1b.
  else if (lavmodel@estimator == "DLS") {
    if (lavmodel@estimator.args$dls.GammaNT == "sample") {
      A1 <- lavsamplestats@WLS.V
    } else {
      A1 <- vector("list", length = lavsamplestats@ngroups)
      for (g in seq_len(lavsamplestats@ngroups)) {
        dls.a <- lavmodel@estimator.args$dls.a
        GammaNT <- lav_samplestats_Gamma_NT(
          COV            = lavimplied$cov[[g]],
          MEAN           = lavimplied$mean[[g]],
          rescale        = FALSE,
          x.idx          = lavsamplestats@x.idx[[g]],
          fixed.x        = lavmodel@fixed.x,
          conditional.x  = lavmodel@conditional.x,
          meanstructure  = lavmodel@meanstructure,
          slopestructure = lavmodel@conditional.x
        )
        W.DLS <- (1 - dls.a) * lavsamplestats@NACOV[[g]] + dls.a * GammaNT
        A1[[g]] <- lav_matrix_symmetric_inverse(W.DLS)
      }
    }
  }

  # 2. DWLS/ULS diagonal @WLS.VD slot
  else if (lavmodel@estimator == "DWLS" || lavmodel@estimator == "ULS") {
    # diagonal only!!
    A1 <- lavsamplestats@WLS.VD
  }

  # 3a. ML single level
  else if (lavmodel@estimator %in% c("ML", "NTRLS", "DLS", "catML") &&
    lavdata@nlevels == 1L) {
    A1 <- vector("list", length = lavsamplestats@ngroups)

    # structured? compute model-implied statistics
    if (structured && length(lavimplied) == 0L) {
      lavimplied <- lav_model_implied(lavmodel)
    }

    for (g in 1:lavsamplestats@ngroups) {
      WT <- lavdata@weights[[g]]

      if (lavsamplestats@missing.flag) {
        # mvnorm
        # FIXME: allow for meanstructure = FALSE
        # FIXME: allow for conditional.x = TRUE
        if (lavmodel@meanstructure && structured) {
          MEAN <- lavimplied$mean[[g]]
        } else {
          #MEAN <- lavsamplestats@missing.h1[[g]]$mu
          MEAN <- lavh1$implied$mean[[g]]
        }

        if (structured) {
          A1[[g]] <-
            lav_mvnorm_missing_information_expected(
              Y = lavdata@X[[g]],
              Mp = lavdata@Mp[[g]],
              wt = WT,
              Mu = MEAN,
              # meanstructure = lavmodel@meanstructure,
              Sigma = lavimplied$cov[[g]],
              x.idx = lavsamplestats@x.idx[[g]]
            )
        } else {
          A1[[g]] <-
            lav_mvnorm_missing_information_expected(
              Y = lavdata@X[[g]],
              Mp = lavdata@Mp[[g]],
              wt = WT,
              Mu = MEAN,
              # meanstructure = lavmodel@meanstructure,
              #Sigma = lavsamplestats@missing.h1[[g]]$sigma,
              Sigma = lavh1$implied$cov[[g]],
              x.idx = lavsamplestats@x.idx[[g]]
            )
        }
      } else {
        if (lavmodel@conditional.x) {
          # mvreg
          if (lavmodel@meanstructure && structured) {
            RES.INT <- lavimplied$res.int[[g]]
            RES.SLOPES <- lavimplied$res.slopes[[g]]
          } else {
            RES.INT <- lavsamplestats@res.int[[g]]
            RES.SLOPES <- lavsamplestats@res.slopes[[g]]
          }

          if (structured) {
            A1[[g]] <- lav_mvreg_information_expected(
              sample.mean.x     = lavsamplestats@mean.x[[g]],
              sample.cov.x      = lavsamplestats@cov.x[[g]],
              sample.nobs       = lavsamplestats@nobs[[g]],
              res.int           = RES.INT,
              res.slopes        = RES.SLOPES,
              # wt               = WT,
              # meanstructure    = lavmodel@meanstructure,
              res.cov           = lavimplied$res.cov[[g]]
            )
          } else {
            A1[[g]] <- lav_mvreg_information_expected(
              sample.mean.x     = lavsamplestats@mean.x[[g]],
              sample.cov.x      = lavsamplestats@cov.x[[g]],
              sample.nobs       = lavsamplestats@nobs[[g]],
              res.int           = lavsamplestats@res.int[[g]],
              res.slopes        = lavsamplestats@res.slopes[[g]],
              # wt               = WT,
              # meanstructure    = lavmodel@meanstructure,
              res.cov           = lavsamplestats@res.cov[[g]]
            )
          }
        } else {
          # conditional.x = FALSE
          # mvnorm
          if (lavmodel@meanstructure && structured) {
            MEAN <- lavimplied$mean[[g]]
          } else {
            MEAN <- lavsamplestats@mean[[g]]
          }

          correlation.flag <- lavmodel@correlation

          if (structured) {
            A1[[g]] <- lav_mvnorm_information_expected(
              Sigma         = lavimplied$cov[[g]],
              # wt = WT, # not needed
              x.idx         = lavsamplestats@x.idx[[g]],
              meanstructure = lavmodel@meanstructure,
              correlation   = correlation.flag
            )
          } else {
            A1[[g]] <- lav_mvnorm_h1_information_expected(
              sample.cov.inv = lavsamplestats@icov[[g]],
              # wt = WT, not needed
              x.idx          = lavsamplestats@x.idx[[g]],
              meanstructure  = lavmodel@meanstructure,
              correlation    = correlation.flag
            )
          }
        } # conditional.x
      } # missing

      # stochastic group weight
      if (lavmodel@group.w.free) {
        # unweight!! (as otherwise, we would 'weight' again)
        a <- exp(lavimplied$group.w[[g]]) / lavsamplestats@nobs[[g]]
        A1[[g]] <- lav_matrix_bdiag(matrix(a, 1L, 1L), A1[[g]])
      }
    } # g
  } # ML

  # 3b. ML + multilevel
  else if (lavmodel@estimator == "ML" && lavdata@nlevels > 1L) {
    A1 <- vector("list", length = lavsamplestats@ngroups)

    # structured? compute model-implied statistics
    if (structured && length(lavimplied) == 0L) {
      lavimplied <- lav_model_implied(lavmodel)
    }

    # structured? lavimplied vs lavh1
    if (structured) {
      implied <- lavimplied
    } else {
      implied <- lavh1$implied
    }

    for (g in 1:lavsamplestats@ngroups) {
      MU.W <- implied$mean[[(g - 1) * lavdata@nlevels + 1L]]
      MU.B <- implied$mean[[(g - 1) * lavdata@nlevels + 2L]]
      SIGMA.W <- implied$cov[[(g - 1) * lavdata@nlevels + 1L]]
      SIGMA.B <- implied$cov[[(g - 1) * lavdata@nlevels + 2L]]

      # clustered data
      A1[[g]] <- lav_mvnorm_cluster_information_expected(
        Lp           = lavdata@Lp[[g]],
        Mu.W         = MU.W,
        Sigma.W      = SIGMA.W,
        Mu.B         = MU.B,
        Sigma.B      = SIGMA.B,
        x.idx        = lavsamplestats@x.idx[[g]]
      )
    } # g
  } # ML + multilevel


  A1
}

lav_model_h1_information_observed <- function(lavobject = NULL,
                                              lavmodel = NULL,
                                              lavsamplestats = NULL,
                                              lavdata = NULL,
                                              lavimplied = NULL,
                                              lavh1 = NULL,
                                              lavcache = NULL,
                                              lavoptions = NULL) {
  if (!is.null(lavobject) && inherits(lavobject, "lavaan")) {
    lavmodel <- lavobject@Model
    lavsamplestats <- lavobject@SampleStats
    lavdata <- lavobject@Data
    lavimplied <- lavobject@implied
    lavh1 <- lavobject@h1
    lavcache <- lavobject@Cache
    lavoptions <- lavobject@Options
  }

  # sanity check
  if (length(lavh1) == 0L) {
    lavh1 <- lav_h1_implied_logl(
      lavdata = lavdata,
      lavsamplestats = lavsamplestats,
      lavoptions = lavoptions
    )
  }
  if (length(lavimplied) == 0L) {
    lavimplied <- lav_model_implied(lavmodel = lavmodel)
  }

  estimator <- lavmodel@estimator

  # structured?
  if (!is.null(lavoptions) &&
    !is.null(lavoptions$h1.information[1]) &&
    lavoptions$h1.information[1] == "unstructured") {
    structured <- FALSE
  } else {
    structured <- TRUE
  }

  # 1. WLS.V (=A1) for GLS/WLS
  if (lavmodel@estimator == "GLS" || lavmodel@estimator == "WLS" ||
    lavmodel@estimator == "DLS") {
    A1 <- lavsamplestats@WLS.V
  }

  # 1b.
  else if (lavmodel@estimator == "DLS") {
    if (lavmodel@estimator.args$dls.GammaNT == "sample") {
      A1 <- lavsamplestats@WLS.V
    } else {
      A1 <- vector("list", length = lavsamplestats@ngroups)
      for (g in seq_len(lavsamplestats@ngroups)) {
        dls.a <- lavmodel@estimator.args$dls.a
        GammaNT <- lav_samplestats_Gamma_NT(
          COV            = lavimplied$cov[[g]],
          MEAN           = lavimplied$mean[[g]],
          rescale        = FALSE,
          x.idx          = lavsamplestats@x.idx[[g]],
          fixed.x        = lavmodel@fixed.x,
          conditional.x  = lavmodel@conditional.x,
          meanstructure  = lavmodel@meanstructure,
          slopestructure = lavmodel@conditional.x
        )
        W.DLS <- (1 - dls.a) * lavsamplestats@NACOV[[g]] + dls.a * GammaNT
        A1[[g]] <- lav_matrix_symmetric_inverse(W.DLS)
      }
    }
  }

  # 2. DWLS/ULS diagonal @WLS.VD slot
  else if (lavmodel@estimator == "DWLS" || lavmodel@estimator == "ULS") {
    # diagonal only!!
    A1 <- lavsamplestats@WLS.VD
  }

  # 3a. ML single level
  else if (lavmodel@estimator == "ML" && lavdata@nlevels == 1L) {
    A1 <- vector("list", length = lavsamplestats@ngroups)

    # structured? compute model-implied statistics
    if (structured && length(lavimplied) == 0L) {
      lavimplied <- lav_model_implied(lavmodel)
    }

    for (g in 1:lavsamplestats@ngroups) {
      if (lavsamplestats@missing.flag) {
        # mvnorm
        # FIXME: allow for meanstructure = FALSE
        # FIXME: allow for conditional.x = TRUE
        if (lavmodel@meanstructure && structured) {
          MEAN <- lavimplied$mean[[g]]
        } else {
          #MEAN <- lavsamplestats@missing.h1[[g]]$mu
          MEAN <- lavh1$implied$mean[[g]]
        }

        if (structured) {
          A1[[g]] <-
            lav_mvnorm_missing_information_observed_samplestats(
              Yp = lavsamplestats@missing[[g]],
              # wt not needed
              Mu = MEAN,
              # meanstructure = lavmodel@meanstructure,
              Sigma = lavimplied$cov[[g]],
              x.idx = lavsamplestats@x.idx[[g]]
            )
        } else {
          A1[[g]] <-
            lav_mvnorm_missing_information_observed_samplestats(
              Yp = lavsamplestats@missing[[g]],
              # wt not needed
              Mu = MEAN,
              # meanstructure = lavmodel@meanstructure,
              #Sigma = lavsamplestats@missing.h1[[g]]$sigma,
              Sigma = lavh1$implied$cov[[g]],
              x.idx = lavsamplestats@x.idx[[g]]
            )
        }
      } else {
        if (lavmodel@conditional.x) {
          # mvreg
          if (lavmodel@meanstructure && structured) {
            RES.INT <- lavimplied$res.int[[g]]
            RES.SLOPES <- lavimplied$res.slopes[[g]]
          } else {
            RES.INT <- lavsamplestats@res.int[[g]]
            RES.SLOPES <- lavsamplestats@res.slopes[[g]]
          }

          if (structured) {
            A1[[g]] <- lav_mvreg_information_observed_samplestats(
              sample.res.int    = lavsamplestats@res.int[[g]],
              sample.res.slopes = lavsamplestats@res.slopes[[g]],
              sample.res.cov    = lavsamplestats@res.cov[[g]],
              sample.mean.x     = lavsamplestats@mean.x[[g]],
              sample.cov.x      = lavsamplestats@cov.x[[g]],
              res.int           = RES.INT,
              res.slopes        = RES.SLOPES,
              # wt               = WT,
              # meanstructure    = lavmodel@meanstructure,
              res.cov           = lavimplied$res.cov[[g]]
            )
          } else {
            A1[[g]] <- lav_mvreg_information_observed_samplestats(
              sample.res.int    = lavsamplestats@res.int[[g]],
              sample.res.slopes = lavsamplestats@res.slopes[[g]],
              sample.res.cov    = lavsamplestats@res.cov[[g]],
              sample.mean.x     = lavsamplestats@mean.x[[g]],
              sample.cov.x      = lavsamplestats@cov.x[[g]],
              res.int           = lavsamplestats@res.int[[g]],
              res.slopes        = lavsamplestats@res.slopes[[g]],
              # wt               = WT,
              # meanstructure    = lavmodel@meanstructure,
              res.cov           = lavsamplestats@res.cov[[g]]
            )
          }
        } else {
          # conditional.x = FALSE
          # mvnorm
          if (lavmodel@meanstructure && structured) {
            MEAN <- lavimplied$mean[[g]]
          } else {
            MEAN <- lavsamplestats@mean[[g]]
          }

          if (structured) {
            A1[[g]] <- lav_mvnorm_information_observed_samplestats(
              sample.mean   = lavsamplestats@mean[[g]],
              sample.cov    = lavsamplestats@cov[[g]],
              Mu            = MEAN,
              Sigma         = lavimplied$cov[[g]],
              # wt           = WT, # not needed
              x.idx         = lavsamplestats@x.idx[[g]],
              meanstructure = lavmodel@meanstructure
            )
          } else {
            A1[[g]] <- lav_mvnorm_h1_information_observed_samplestats(
              sample.mean    = lavsamplestats@mean[[g]],
              sample.cov     = lavsamplestats@cov[[g]],
              sample.cov.inv = lavsamplestats@icov[[g]],
              # wt            = WT, not needed
              x.idx          = lavsamplestats@x.idx[[g]],
              meanstructure  = lavmodel@meanstructure
            )
          }
        } # conditional.x
      } # missing

      # stochastic group weight
      if (lavmodel@group.w.free) {
        # unweight!!
        a <- exp(lavimplied$group.w[[g]]) / lavsamplestats@nobs[[g]]
        A1[[g]] <- lav_matrix_bdiag(matrix(a, 1, 1), A1[[g]])
      }
    } # g
  } # ML

  # 3b. ML + multilevel
  else if (lavmodel@estimator == "ML" && lavdata@nlevels > 1L) {
    A1 <- vector("list", length = lavsamplestats@ngroups)

    # structured? compute model-implied statistics
    if (structured && length(lavimplied) == 0L) {
      lavimplied <- lav_model_implied(lavmodel)
    }

    # structured? lavimplied vs lavh1
    if (structured) {
      implied <- lavimplied
    } else {
      implied <- lavh1$implied
    }

    for (g in 1:lavsamplestats@ngroups) {
      MU.W <- implied$mean[[(g - 1) * lavdata@nlevels + 1L]]
      MU.B <- implied$mean[[(g - 1) * lavdata@nlevels + 2L]]
      SIGMA.W <- implied$cov[[(g - 1) * lavdata@nlevels + 1L]]
      SIGMA.B <- implied$cov[[(g - 1) * lavdata@nlevels + 2L]]

      if (lavdata@missing == "ml") {
          A1[[g]] <- lav_mvnorm_cluster_missing_information_observed(
            Y1            = lavdata@X[[g]],
            Y2            = lavsamplestats@YLp[[g]][[2]]$Y2,
            Lp            = lavdata@Lp[[g]],
            Mp            = lavdata@Mp[[g]],
            Mu.W          = MU.W,
            Sigma.W       = SIGMA.W,
            Mu.B          = MU.B,
            Sigma.B       = SIGMA.B,
            x.idx         = lavsamplestats@x.idx[[g]]
          )
      } else {
        A1[[g]] <- lav_mvnorm_cluster_information_observed(
          Lp           = lavdata@Lp[[g]],
          YLp          = lavsamplestats@YLp[[g]],
          Mu.W         = MU.W,
          Sigma.W      = SIGMA.W,
          Mu.B         = MU.B,
          Sigma.B      = SIGMA.B,
          x.idx        = lavsamplestats@x.idx[[g]]
        )
      }
    } # g
  } # ML + multilevel

  A1
}

# outer product of the case-wise scores (gradients)
# HJ 18/10/2023: Adjust J matrix correctly using weights. Note: H matrix is
# based on lav_model_hessian so no changes required.
lav_model_h1_information_firstorder <- function(lavobject = NULL,
                                                lavmodel = NULL,
                                                lavsamplestats = NULL,
                                                lavdata = NULL,
                                                lavimplied = NULL,
                                                lavh1 = NULL,
                                                lavcache = NULL,
                                                lavoptions = NULL) {
  if (!is.null(lavobject) && inherits(lavobject, "lavaan")) {
    lavmodel <- lavobject@Model
    lavsamplestats <- lavobject@SampleStats
    lavdata <- lavobject@Data
    lavimplied <- lavobject@implied
    lavh1 <- lavobject@h1
    lavcache <- lavobject@Cache
    lavoptions <- lavobject@Options
  }

  # sanity check
  if (length(lavh1) == 0L) {
    lavh1 <- lav_h1_implied_logl(
      lavdata = lavdata,
      lavsamplestats = lavsamplestats,
      lavoptions = lavoptions
    )
  }
  if (length(lavimplied) == 0L) {
    lavimplied <- lav_model_implied(lavmodel = lavmodel)
  }

  estimator <- lavmodel@estimator
  if (!estimator %in% c("ML", "PML")) {
    lav_msg_stop(gettext(
      "information = \"first.order\" not available for estimator"),
      sQuote(estimator))
  }

  # structured?
  if (!is.null(lavoptions) &&
    !is.null(lavoptions$h1.information[1]) &&
    lavoptions$h1.information[1] == "unstructured") {
    structured <- FALSE
  } else {
    structured <- TRUE
  }

  # clustered?
  if (!is.null(lavoptions) &&
    !is.null(lavoptions$.clustered) &&
    lavoptions$.clustered) {
    clustered <- TRUE
    if (is.null(lavdata@Lp[[1]])) {
      lav_msg_stop(gettext("lavdata@Lp is empty, while clustered = TRUE"))
    }
    # if (estimator == "PML") {
    #   lav_msg_stop(gettext(
    #     "clustered information is not (yet) available when estimator = 'PML'"))
    # }
    # if(lavsamplestats@missing.flag) {
    #    stop("lavaan ERROR: clustered information is not (yet) available when missing = \"ML\"")
    # }
    # if(lavmodel@conditional.x) {
    #    stop("lavaan ERROR: clustered information is not (yet) available when conditional.x = TRUE")
    # }
    # if(!structured) {
    #    stop("lavaan ERROR: clustered information is not (yet) available when h1.information = \"unstructured\"")
    # }
  } else {
    clustered <- FALSE
  }

  # structured? compute model-implied statistics
  if (estimator == "PML" || structured) {
    if (length(lavimplied) == 0L) {
      lavimplied <- lav_model_implied(lavmodel)
    }
  }

  # structured? lavimplied vs lavh1
  if (structured) {
    implied <- lavimplied
  } else {
    implied <- lavh1$implied
  }

  B1 <- vector("list", length = lavsamplestats@ngroups)
  for (g in 1:lavdata@ngroups) {
    WT <- lavdata@weights[[g]]

    if (estimator == "PML") {
      # slow approach: compute outer product of case-wise scores

      if (lavmodel@conditional.x) {
        SIGMA <- implied$res.cov[[g]]
        MU <- implied$res.mean[[g]]
        TH <- implied$res.th[[g]]
        PI <- implied$res.slopes[[g]]
        EXO <- lavdata@eXo[[g]]
      } else {
        SIGMA <- implied$cov[[g]]
        MU <- implied$mean[[g]]
        TH <- implied$th[[g]]
        PI <- NULL
        EXO <- NULL
      }
      SC <- lav_pml_dploglik_dimplied(
        Sigma.hat = SIGMA,
        Mu.hat = MU,
        TH = TH,
        th.idx = lavmodel@th.idx[[g]],
        num.idx = lavmodel@num.idx[[g]],
        X = lavdata@X[[g]],
        eXo = EXO,
        wt = NULL,
        PI = PI,
        lavcache = lavcache[[g]],
        missing = lavdata@missing,
        scores = TRUE,
        negative = FALSE
      )

      # >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>


      # information H1

      if (isTRUE(clustered)) {
        # For clustered data, need to compute (centred) crossprod within each
        # cluster and sum them all up.
        clusters     <- lavdata@Lp[[g]]$cluster.id[[2]]  # why list of 2?
        clusters.idx <- lavdata@Lp[[g]]$cluster.idx[[2]]
        nclust       <- length(clusters)
        zb <- list()

        if (is.null(WT)) WT <- rep(1, length(clusters.idx))

        for (b in seq_along(clusters)) {
          SC_b <- SC[clusters.idx == b, ]
          WT_b <- WT[clusters.idx == b]
          zb[[b]] <- apply(SC_b * WT_b, 2, sum)
        }
        zbar <- apply(do.call(cbind, zb), 1, mean)
        B1c <- Reduce(f = `+`, lapply(zb, function(z) tcrossprod(z - zbar)))
        B1[[g]] <- nclust / (nclust - 1) * B1c

      } else {
        if (is.null(WT)) {
          B1[[g]] <- lav_matrix_crossprod(SC)
        } else {
          B1[[g]] <- crossprod(WT * SC)
        }
      }
    } else if (estimator == "ML" && lavdata@nlevels > 1L) {
      # if not-structured, we use lavh1, and that is always
      # 'unconditional' (for now)
      if (lavmodel@conditional.x && structured) {
	    if (lavdata@missing == "ml") {
		  lav_msg_stop(gettext("firstorder information matrix not available
                                (yet) if conditional.x + fiml"))
		}
        Res.Sigma.W <- implied$res.cov[[(g - 1) * lavdata@nlevels + 1L]]
        Res.Int.W <- implied$res.int[[(g - 1) * lavdata@nlevels + 1L]]
        Res.Pi.W <- implied$res.slopes[[(g - 1) * lavdata@nlevels + 1L]]

        Res.Sigma.B <- implied$res.cov[[(g - 1) * lavdata@nlevels + 2L]]
        Res.Int.B <- implied$res.int[[(g - 1) * lavdata@nlevels + 2L]]
        Res.Pi.B <- implied$res.slopes[[(g - 1) * lavdata@nlevels + 2L]]
        B1[[g]] <- lav_mvreg_cluster_information_firstorder(
          Y1            = lavdata@X[[g]],
          YLp           = lavsamplestats@YLp[[g]],
          Lp            = lavdata@Lp[[g]],
          Res.Sigma.W   = Res.Sigma.W,
          Res.Int.W     = Res.Int.W,
          Res.Pi.W      = Res.Pi.W,
          Res.Sigma.B   = Res.Sigma.B,
          Res.Int.B     = Res.Int.B,
          Res.Pi.B      = Res.Pi.B,
          divide.by.two = TRUE
        )
      } else {
        MU.W <- implied$mean[[(g - 1) * lavdata@nlevels + 1L]]
        MU.B <- implied$mean[[(g - 1) * lavdata@nlevels + 2L]]
        SIGMA.W <- implied$cov[[(g - 1) * lavdata@nlevels + 1L]]
        SIGMA.B <- implied$cov[[(g - 1) * lavdata@nlevels + 2L]]
		if (lavdata@missing == "ml") {
          B1[[g]] <- lav_mvnorm_cluster_missing_information_firstorder(
            Y1            = lavdata@X[[g]],
            Y2            = lavsamplestats@YLp[[g]][[2]]$Y2,
            Lp            = lavdata@Lp[[g]],
            Mp            = lavdata@Mp[[g]],
            Mu.W          = MU.W,
            Sigma.W       = SIGMA.W,
            Mu.B          = MU.B,
            Sigma.B       = SIGMA.B,
            x.idx         = lavsamplestats@x.idx[[g]],
            divide.by.two = TRUE
          )
		} else {
		  # no missing values
          B1[[g]] <- lav_mvnorm_cluster_information_firstorder(
            Y1            = lavdata@X[[g]],
            YLp           = lavsamplestats@YLp[[g]],
            Lp            = lavdata@Lp[[g]],
            Mu.W          = MU.W,
            Sigma.W       = SIGMA.W,
            Mu.B          = MU.B,
            Sigma.B       = SIGMA.B,
            x.idx         = lavsamplestats@x.idx[[g]],
            divide.by.two = TRUE
          )
		}
      }
    } else if (estimator == "ML" && lavdata@nlevels == 1L) {
      if (length(lavdata@cluster) > 0L) {
        cluster.idx <- lavdata@Lp[[g]]$cluster.idx[[2]]
      } else {
        cluster.idx <- NULL
      }

      if (lavsamplestats@missing.flag) {
        # mvnorm
        # FIXME: allow for meanstructure = FALSE
        # FIXME: allow for conditional.x = TRUE
        if (lavmodel@meanstructure && structured) {
          MEAN <- lavimplied$mean[[g]]
        } else {
          #MEAN <- lavsamplestats@missing.h1[[g]]$mu
          MEAN <- lavh1$implied$mean[[g]]
        }

        B1[[g]] <- lav_mvnorm_missing_information_firstorder(
          Y = lavdata@X[[g]],
          Mp = lavdata@Mp[[g]], wt = WT,
          cluster.idx = cluster.idx,
          Mu = MEAN,
          # meanstructure = lavmodel@meanstructure,
          Sigma = implied$cov[[g]],
          x.idx = lavsamplestats@x.idx[[g]]
        )
      } else {
        if (lavmodel@conditional.x) {
          # mvreg
          if (lavmodel@meanstructure && structured) {
            RES.INT <- lavimplied$res.int[[g]]
            RES.SLOPES <- lavimplied$res.slopes[[g]]
          } else {
            RES.INT <- lavsamplestats@res.int[[g]]
            RES.SLOPES <- lavsamplestats@res.slopes[[g]]
          }

          B1[[g]] <- lav_mvreg_information_firstorder(
            Y              = lavdata@X[[g]],
            eXo            = lavdata@eXo[[g]],
            res.int        = RES.INT,
            res.slopes     = RES.SLOPES,
            # wt            = WT,
            # meanstructure = lavmodel@meanstructure,
            res.cov        = implied$res.cov[[g]]
          )
        } else {
          # conditional.x = FALSE
          # mvnorm
          if (lavmodel@meanstructure && structured) {
            MEAN <- lavimplied$mean[[g]]
          } else {
            # NOTE: the information matrix will be the same (minus
            # the meanstructure block), but once INVERTED, the
            # standard errors will be (slightly) smaller!!!
            # This is only visibile when estimator = "MLF"
            # (or information = "first.order")
            MEAN <- lavsamplestats@mean[[g]] # saturated
          }

          if (structured) {
            B1[[g]] <- lav_mvnorm_information_firstorder(
              Y = lavdata@X[[g]],
              Mu = MEAN, Sigma = lavimplied$cov[[g]],
              wt = WT,
              cluster.idx = cluster.idx,
              x.idx = lavsamplestats@x.idx[[g]],
              meanstructure = lavmodel@meanstructure
            )
          } else {
            B1[[g]] <- lav_mvnorm_h1_information_firstorder(
              Y = lavdata@X[[g]],
              sample.cov.inv = lavsamplestats@icov[[g]],
              Gamma = lavsamplestats@NACOV[[g]],
              wt = WT,
              cluster.idx = cluster.idx, # only if wt
              x.idx = lavsamplestats@x.idx[[g]],
              meanstructure = lavmodel@meanstructure
            )
          }
        } # mvnorm
      } # missing
    } # ML

    # stochastic group weight
    if (lavmodel@group.w.free) {
      # unweight!!
      a <- exp(lavimplied$group.w[[g]]) / lavsamplestats@nobs[[g]]
      B1[[g]] <- lav_matrix_bdiag(matrix(a, 1, 1), B1[[g]])
    }
  } # g

  B1
}


# asymptotic variance matrix (=Gamma/N) of the unrestricted (H1)
# sample statistics
#
# FIXME: make this work for categorical/GLS/WLS/...
#
lav_model_h1_acov <- function(lavobject = NULL,
                              lavmodel = NULL,
                              lavsamplestats = NULL,
                              lavdata = NULL,
                              lavoptions = NULL,
                              lavimplied = NULL,
                              lavh1 = NULL,
                              lavcache = NULL,
                              meanstructure = NULL, # if specified, use it
                              h1.information = NULL, # if specified, use it
                              se = NULL) { # if specified, use it

  if (!is.null(lavobject) && inherits(lavobject, "lavaan")) {
    lavmodel <- lavobject@Model
    lavsamplestats <- lavobject@SampleStats
    lavdata <- lavobject@Data
    lavimplied <- lavobject@implied
    lavh1 <- lavobject@h1
    lavcache <- lavobject@Cache
    lavoptions <- lavobject@Options
  }

  # sanity check
  if (length(lavh1) == 0L) {
    lavh1 <- lav_h1_implied_logl(
      lavdata = lavdata,
      lavsamplestats = lavsamplestats,
      lavoptions = lavoptions
    )
  }
  if (length(lavimplied) == 0L) {
    lavimplied <- lav_model_implied(lavmodel = lavmodel)
  }

  # override
  if (!is.null(meanstructure)) {
    lavoptions$meanstructure <- meanstructure
  }
  if (!is.null(h1.information)) {
    lavoptions$h1.information[1] <- h1.information
  }
  if (!is.null(se)) {
    lavoptions$se <- se
  }


  # information
  information <- lavoptions$information[1] # ALWAYS used the first

  # compute information matrix
  if (information == "observed") {
    I1 <- lav_model_h1_information_observed(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavimplied = lavimplied, lavh1 = lavh1,
      lavcache = lavcache, lavoptions = lavoptions
    )
  } else if (information == "expected") {
    I1 <- lav_model_h1_information_expected(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavimplied = lavimplied, lavh1 = lavh1,
      lavcache = lavcache, lavoptions = lavoptions
    )
  } else if (information == "first.order") {
    I1 <- lav_model_h1_information_firstorder(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavimplied = lavimplied, lavh1 = lavh1,
      lavcache = lavcache, lavoptions = lavoptions
    )
  }

  if (lavoptions$se %in% c("robust.huber.white", "robust.sem")) {
    J1 <- lav_model_h1_information_firstorder(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavimplied = lavimplied, lavh1 = lavh1,
      lavcache = lavcache, lavoptions = lavoptions
    )
  }

  # compute ACOV per group
  ACOV <- vector("list", length = lavdata@ngroups)
  for (g in 1:lavdata@ngroups) {
    # denominator
    if (lavdata@nlevels == 1L) {
      Ng <- lavsamplestats@nobs[[g]]
    } else {
      Ng <- lavdata@Lp[[g]]$nclusters[[2]]
    }

    # invert information
    I1.g.inv <- try(lav_matrix_symmetric_inverse(I1[[g]]), silent = TRUE)
    if (inherits(I1.g.inv, "try-error")) {
      lav_msg_stop(gettext(
        "could not invert h1 information matrix in group"), g)
    }

    # which type of se?
    if (lavoptions$se %in% c("standard", "none")) {
      ACOV[[g]] <- 1 / Ng * I1.g.inv
    } else if (lavoptions$se %in% c("robust.huber.white", "robust.sem")) {
      ACOV[[g]] <- 1 / Ng * (I1.g.inv %*% J1[[g]] %*% I1.g.inv)
    }
  }

  ACOV
}

# contributed by Ed Merkle (17 Jan 2013)
# WLS version contributed by Franz Classe (March 2024)
# (adapted for inclusion in lavaan by YR)


# YR 12 Feb 2013: small changes to match the results of lav_model_gradient
#                 in the multiple group case
# YR 30 May 2014: handle 1-variable case (fixing apply in lines 56, 62, 108)
# YR 05 Nov 2015: add remove.duplicated = TRUE, to cope with strucchange in
#                 case of simple equality constraints
# YR 19 Nov 2015: if constraints have been used, compute case-wise Lagrange
#                 multipliers, and define the scores as: SC + (t(R) lambda)
# YR 05 Feb 2016: catch conditional.x = TRUE: no support (for now), until
#                 we can use the generic 0.6 infrastructure for scores,
#                 including the missing-values case
# YR 16 Feb 2016: adapt to changed @Mp slot elements; add remove.empty.cases=
#                 argument
# YR 12 Mar 2024: make lintr (more) happy; include WLS code from Franz Classe
#                 move ML-specific code to lav_scores_ml() function
# YR 26 Apr 2025: add lav_scores_gls()

lav_scores <- function(object, scaling = FALSE, # nolint
                                       ignore.constraints = FALSE,
                                       remove.duplicated = TRUE,
                                       remove.empty.cases = TRUE) {
  stopifnot(inherits(object, "lavaan"))

  # check object
  object <- lav_object_check_version(object)

  # what if estimator is not ML or WLS?
  # avoid hard error (using stop); throw a warning, and return an empty matrix
  if (!object@Options$estimator %in% c("ML", "WLS", "GLS", "ULS")) {
    lav_msg_warn(gettext("scores only availalbe if estimator is ML"))
    return(matrix(0, 0, 0))
  }

  # check if conditional.x = TRUE
  if (object@Model@conditional.x) {
    lav_msg_stop(gettext("scores not available (yet) if conditional.x = TRUE"))
  }

  # shortcuts
  lavdata <- object@Data
  lavmodel <- object@Model
  lavsamplestats <- object@SampleStats
  lavoptions <- object@Options

  ## number variables/sample size
  # ntab <- unlist(lavsamplestats@nobs)
  ## change in 0.5-17: we keep the 'empty cases'
  ##                   and 'fill' in the scores at their 'case.idx'
  ##                   later, we remove the 'empty rows'
  # ntot <- max( object@Data@case.idx[[ object@Data@ngroups ]] )
  ntab <- unlist(lavdata@norig)
  ntot <- sum(ntab)
  npar <- lav_object_inspect_npar(object, ceq = FALSE)

  if (object@Options$estimator == "ML") {
    moments <- fitted(object)
    score_matrix <- lav_scores_ml(
      ntab = ntab, ntot = ntot, npar = npar,
      moments = moments, lavdata = lavdata, lavsamplestats = lavsamplestats,
      lavmodel = lavmodel, lavoptions = lavoptions, scaling = scaling
    )
  } else if (object@Options$estimator == "WLS" && lavmodel@categorical) {
    # check if ALL observed variables are ordered
    ov.names <- unlist(lavdata@ov.names)
    ov.idx <- which(lavdata@ov$name %in% ov.names)
    if (!all(lavdata@ov$type[ov.idx] == "ordered")) {
      lav_msg_stop(gettext(
        "WLS scores only available if all observed variables are ordered."))
    }

    # compute WLS scores
    score_matrix <- lav_scores_wls(
      ntab = ntab, ntot = ntot, npar = npar,
      lavdata = lavdata, lavsamplestats = lavsamplestats,
      lavmodel = lavmodel, lavoptions = lavoptions
    )
  } else if (!lavmodel@categorical &&
             object@Options$estimator %in% c("GLS", "ULS", "WLS")) {
    # compute WLS/GLS/ULS `scores'
    score_matrix <- lav_scores_ls(
      ntab = ntab, ntot = ntot, npar = npar,
      lavdata = lavdata, lavsamplestats = lavsamplestats,
      lavmodel = lavmodel, lavoptions = lavoptions
    )
  } else {
    # should not happen
    lav_msg_fixme("this should not happen")
  }

  # handle empty rows
  if (remove.empty.cases) {
    # empty.idx <- which( apply(score_matrix, 1L,
    #                        function(x) sum(is.na(x))) == ncol(score_matrix) )
    empty.idx <- unlist(lapply(lavdata@Mp, "[[", "empty.idx"))
    if (length(empty.idx) > 0L) {
      score_matrix <- score_matrix[-empty.idx, , drop = FALSE]
    }
  }

  # provide column names
  colnames(score_matrix) <- names(lav_object_inspect_coef(object,
    type = "free", add.labels = TRUE
  ))

  # handle general constraints, so that the sum of the columns equals zero
  if (!ignore.constraints &&
    sum(
      lavmodel@ceq.linear.idx, lavmodel@ceq.nonlinear.idx,
      lavmodel@cin.linear.idx, lavmodel@cin.nonlinear.idx
    ) > 0) {
    r_matrix <- object@Model@con.jac[, ]
    pre <- lav_constraints_lambda_pre(object)
    # LAMBDA <- -1 * t(pre %*% t(score_matrix))
    # RLAMBDA <- t(t(r_matrix) %*% t(LAMBDA))
    score_matrix <- score_matrix - t(t(r_matrix) %*% pre %*% t(score_matrix))
  }

  # handle simple equality constraints
  if (remove.duplicated && lavmodel@eq.constraints) {
    simple.flag <- lav_constraints_check_simple(lavmodel)
    if (simple.flag) {
      k_matrix <- lav_constraints_R2K(lavmodel)
      score_matrix <- score_matrix %*% k_matrix
    } else {
      lav_msg_warn(gettext(
        "remove.duplicated is TRUE, but equality constraints do not appear
        to be simple; returning full scores"))
    }
  }

  score_matrix
}
lavScores <- lav_scores       # synonym #nolint
estfun.lavaan <- lav_scores   # synonym

lav_scores_ml <- function(ntab = 0L,
                          ntot = 0L,
                          npar = 0L,
                          moments = NULL,
                          lavdata = NULL,
                          lavsamplestats = NULL,
                          lavmodel = NULL,
                          lavoptions = NULL,
                          scaling = FALSE) {
  score_matrix <- matrix(NA, ntot, npar)

  # Delta matrix
  Delta <- lav_model_delta(lavmodel = lavmodel)

  # rename moments
  moments.groups <- moments

  for (g in 1:lavsamplestats@ngroups) {
    if (lavsamplestats@ngroups > 1) {
      moments <- moments.groups[[g]]
    }
    sigma_hat <- moments$cov

    if (lavoptions$likelihood == "wishart") {
      nobs1 <- lavsamplestats@nobs[[g]] / (lavsamplestats@nobs[[g]] - 1)
    } else {
      nobs1 <- 1
    }

    if (!lavsamplestats@missing.flag) { # complete data
      # if(lavmodel@meanstructure) { # mean structure
      nvar <- ncol(lavsamplestats@cov[[g]])
      mu_hat <- moments$mean
      X <- lavdata@X[[g]]
      sigma_inv <- chol2inv(chol(sigma_hat)) # FIXME: check for pd?
      group.w <- (unlist(lavsamplestats@nobs) / lavsamplestats@ntotal)

      J <- matrix(1, 1L, ntab[g]) ## FIXME: needed? better maybe rowSums/colSums?
      J2 <- matrix(1, nvar, nvar)
      diag(J2) <- 0.5

      if (lavmodel@meanstructure) {
        ## scores_h1 (H1 = saturated model)
        mean.diff <- t(t(X) - mu_hat %*% J)
        dx_mu <- -1 * mean.diff %*% sigma_inv
        dx_sigma <- t(matrix(apply(
          mean.diff, 1L,
          function(x) {
            lav_matrix_vech(-J2 *
              (sigma_inv %*% (tcrossprod(x) * nobs1 - sigma_hat) %*% sigma_inv))
          }
        ), ncol = nrow(mean.diff)))

        scores_h1 <- cbind(dx_mu, dx_sigma)
      } else {
        mean.diff <- t(t(X) - lavsamplestats@mean[[g]] %*% J)
        dx_sigma <- t(matrix(apply(
          mean.diff, 1L,
          function(x) {
            lav_matrix_vech(-J2 *
              (sigma_inv %*% (tcrossprod(x) * nobs1 - sigma_hat) %*% sigma_inv))
          }
        ), ncol = nrow(mean.diff)))
        scores_h1 <- dx_sigma
      }
      ## FIXME? Seems like we would need group.w even in the
      ##        complete-data case:
      ## if(scaling){
      ##  scores_h1 <- group.w[g] * scores_h1
      ## }

      # } else {
      #  ## no mean structure
      #  stop("Score calculation with no mean structure is not implemented.")
      # }
    } else { # incomplete data
      nsub <- ntab[g]
      M <- lavsamplestats@missing[[g]]
      Mp <- lavdata@Mp[[g]]
      # pat.idx <- match(MP1$id, MP1$order)
      group.w <- (unlist(lavsamplestats@nobs) / lavsamplestats@ntotal)

      mu_hat <- moments$mean
      nvar <- ncol(lavsamplestats@cov[[g]])
      score.sigma <- matrix(0, nsub, nvar * (nvar + 1) / 2)
      score.mu <- matrix(0, nsub, nvar)

      for (p in seq_len(length(M))) {
        ## Data
        # X <- M[[p]][["X"]]
        case.idx <- Mp$case.idx[[p]]
        var.idx <- M[[p]][["var.idx"]]
        X <- lavdata@X[[g]][case.idx, var.idx, drop = FALSE]
        nobs <- M[[p]][["freq"]]
        ## Which unique entries of covariance matrix are estimated?
        ## (Used to keep track of scores in score.sigma)
        var.idx.mat <- tcrossprod(var.idx)
        sigma.idx <-
          which(var.idx.mat[lower.tri(var.idx.mat, diag = TRUE)] == 1)

        J <- matrix(1, 1L, nobs) # [var.idx]
        J2 <- matrix(1, nvar, nvar)[var.idx, var.idx, drop = FALSE]
        diag(J2) <- 0.5
        # FIXME: check for pd?
        sigma_inv <- chol2inv(chol(sigma_hat[var.idx, var.idx, drop = FALSE]))
        Mu <- mu_hat[var.idx]
        mean.diff <- t(t(X) - Mu %*% J)

        ## Scores for missing pattern p within group g
        score.mu[case.idx, var.idx] <- -1 * mean.diff %*% sigma_inv
        score.sigma[case.idx, sigma.idx] <- t(matrix(apply(
          mean.diff, 1L,
          function(x) {
            lav_matrix_vech(-J2 *
              (sigma_inv %*% (tcrossprod(x) -
                sigma_hat[var.idx, var.idx, drop = FALSE]) %*% sigma_inv))
          }
        ), ncol = nrow(mean.diff)))
      }

      scores_h1 <- cbind(score.mu, score.sigma)
      if (scaling) {
        scores_h1 <- group.w[g] * scores_h1
      }
    } # missing

    # if(lavmodel@eq.constraints) {
    #    Delta <- Delta %*% lavmodel@eq.constraints.K
    #    #x <- as.numeric(lavmodel@eq.constraints.K %*% x) +
    #    #                lavmodel@eq.constraints.k0
    # }
    wi <- lavdata@case.idx[[g]]
    score_matrix[wi, ] <- -scores_h1 %*% Delta[[g]]
    if (scaling) {
      score_matrix[wi, ] <- (-1 / ntot) * score_matrix[wi, ]
    }
  } # g

  score_matrix
}

# this function is based on code originally written by Franz Classe (Munich)
# for categorical data only!
lav_scores_wls <- function(ntab = 0L,
                           ntot = 0L,
                           npar = 0L,
                           lavdata = NULL,
                           lavsamplestats = NULL,
                           lavmodel = NULL,
                           lavoptions = NULL) {
  # internal function
  doDummySingleVar <- function(X, lv, ntot, num) {
    Xd <- matrix(NA, nrow = ntot, ncol = lv[num] - 1)
    x <- X[, num]
    minx <- min(x)
    categ <- minx - 1
    v <- 1
    while (categ < lv[num] - 1) {
      categ <- categ + 1
      Xd[, v] <- ifelse(x > categ, 1, 0)
      v <- v + 1
    }

    Xd
  }

  # containere for scores
  score_matrix <- matrix(NA, ntot, npar)

  # Delta matrix
  Delta <- lav_model_delta(lavmodel = lavmodel)

  # shortcuts
  lv <- lavdata@ov[["nlev"]]

  for (g in 1:lavsamplestats@ngroups) {
    nvar <- ncol(lavsamplestats@cov[[g]])
    X <- lavdata@X[[g]]

    # convert categorical data to dummy variables
    # FIXME: skip continuous variables
    Xd <- do.call(
      cbind,
      lapply(
        1:nvar,
        function(i) doDummySingleVar(X, lv, ntot, i)
      )
    )

    # e1
    musd <- colMeans(Xd)
    e1 <- t(t(Xd) - musd)

    # e2
    mus <- colMeans(X)
    y_minus_mu <- t(apply(X, 1L, function(x) x - mus))
    s_vech <- t(apply(y_minus_mu, 1L, function(i) {
      lavaan::lav_matrix_vech(tcrossprod(i), diagonal = FALSE)
    })) # s=c( (y1-mu1)(y2-mu2)....
    sigma <- colMeans(s_vech)
    e2 <- t(apply(s_vech, 1L, function(x) x - sigma))

    # e
    e <- cbind(e1, e2)

    # weight matrix
    W <- lavsamplestats@WLS.V[[g]]

    # combine matrices
    wi <- lavdata@case.idx[[g]]
    score_matrix[wi, ] <- t(t(Delta[[g]]) %*% W %*% t(e))
  } # g

  score_matrix
}


# wls/gls/uls (continuous data only)
lav_scores_ls <- function(ntab = 0L,
                          ntot = 0L,
                          npar = 0L,
                          lavdata = NULL,
                          lavsamplestats = NULL,
                          lavmodel = NULL,
                          lavoptions = NULL) {

  # containere for scores
  score_matrix <- matrix(NA, ntot, npar)

  # estimator
  estimator <- lavoptions$estimator

  # Delta matrix
  Delta <- lav_model_delta(lavmodel = lavmodel)

  # implied stats
  implied <- lav_model_implied(lavmodel)

  for (g in 1:lavsamplestats@ngroups) {
    nvar <- ncol(lavsamplestats@cov[[g]])
    nobs <- lavsamplestats@nobs[[g]]
    Y <- lavdata@X[[g]]

    # center (not using model-implied!)
    Yc <- t(t(Y) - colMeans(Y, na.rm = TRUE))

    # create Z where the rows_i contain the following elements:
    #  - Y_i (if meanstructure is TRUE)
    #  - vech(Yc_i' %*% Yc_i) where Yc_i are the residuals
    idx1 <- lav_matrix_vech_col_idx(nvar)
    idx2 <- lav_matrix_vech_row_idx(nvar)
    if (lavmodel@meanstructure) {
      Z <- cbind(Y, Yc[, idx1, drop = FALSE] * Yc[, idx2, drop = FALSE])
    } else {
      Z <- (Yc[, idx1, drop = FALSE] * Yc[, idx2, drop = FALSE])
    }

    # model-based sample statistics
    if (lavmodel@meanstructure) {
      sigma <- c(as.numeric(implied$mean[[g]]),
                 lav_matrix_vech(implied$cov[[g]]))
    } else {
      sigma <- lav_matrix_vech(implied$cov[[g]])
    }

    # adjust sigma for N-1, so that colMeans(scores) == gradient
    # (not for the means)
    if (lavmodel@meanstructure) {
      Z[,-seq_len(nvar)] <- Z[,-seq_len(nvar), drop = FALSE] * nobs / (nobs - 1)
    } else {
      Z <- Z * nobs / (nobs - 1)
    }

    # compute Zc
    Zc <- t(t(Z) - sigma)

    # weight matrix
    if (estimator == "ULS") {
      W <- diag(ncol(Z))
    } else {
      W <- lavsamplestats@WLS.V[[g]]
    }

    # combine matrices
    wi <- lavdata@case.idx[[g]]
    score_matrix[wi, ] <- Zc %*% W %*% Delta[[g]]
  } # g

  score_matrix
}

# chi-square test statistic:
# comparing the current model versus the saturated/unrestricted model
# TDJ 9 April 2024: Add a (hidden) function to update the @test slot
#                   when the user provides a custom h1 model.  Called by
#                   lav_object_summary and lav_fit_measures(_check_baseline)

lavTest <- function(lavobject, test = "standard",
                    scaled.test = "standard",
                    output = "list", drop.list.single = TRUE) {

  # check object
  lavobject <- lav_object_check_version(lavobject)

  # check output
  output.valid <- c("list", "text")
  if (!any(output == output.valid)) {
      lav_msg_stop(gettextf(
        "%1$s argument must be either %2$s",
        "output", lav_msg_view(output.valid, "or")
      ))
  }
  # extract 'test' slot
  TEST <- lavobject@test

  # backwards compatibility:
  # if (length(TEST) > 0L && is.null(names(TEST))) {
  #   names(TEST) <- sapply(TEST, "[[", "test")
  # }

  # which test?
  if (!missing(test)) {
    # check 'test'
    if (!is.character(test)) {
      lav_msg_stop(
        gettextf("%s should be a character string.", "test"))
    } else {
      test <- lav_test_rename(test, check = TRUE)
    }

    # check scaled.test
    if (!missing(scaled.test)) {
      if (!is.character(scaled.test)) {
        lav_msg_stop(
          gettextf("%s should be a character string.", "scaled.test"))
      } else {
        scaled.test <- lav_test_rename(scaled.test, check = TRUE)
      }

      # merge
      test <- unique(c(test, scaled.test))

      # but "standard" must always be first
      standard.idx <- which(test == "standard")
      if (length(standard.idx) > 0L && standard.idx != 1L) {
        test <- c("standard", test[-standard.idx])
      }
    }

    if (test[1] == "none") {
      return(list())
    } else if (any(test %in% c("bootstrap", "bollen.stine"))) {
      lav_msg_stop(gettext(
      "please use lavBootstrap() to obtain a bootstrap based test statistic."
      ))
    }

    # check if we already have it:
    if (all(test %in% names(TEST))) {
      info.attr <- attr(TEST, "info")
      test.idx <- which(names(TEST) %in% test)
      TEST <- TEST[test.idx]
      attr(TEST, "info") <- info.attr
    } else {
      # redo ALL of them, even if already have some in TEST
      # later, we will allow to also change the options (like information)
      # and this should be reflected in the 'info' attribute

      # fill-in test in Options slot
      lavobject@Options$test <- test

      # fill-in scaled.test in Options slot
      lavobject@Options$scaled.test <- scaled.test

      # get requested test statistics
      TEST <- lav_model_test(lavobject = lavobject)
    }
  }

  if (output == "list") {
    # remove 'info' attribute
    attr(TEST, "info") <- NULL

    # select only those that were requested (eg remove standard)
    test.idx <- which(names(TEST) %in% test)
    TEST <- TEST[test.idx]

    # if only 1 test, drop outer list
    if (length(TEST) == 1L && drop.list.single) {
      TEST <- TEST[[1]]
    }

    return(TEST)
  } else {
    lav_test_print(TEST)
  }

  invisible(TEST)
}

# allow for 'flexible' names for the test statistics
# 0.6-13: if multiple names, order them in such a way
#         that the 'scaled' variants appear after the others
lav_test_rename <- function(test, check = FALSE) {
  test <- tolower(test)

  if (length(target.idx <- which(test %in%
    c("standard", "chisq", "chi", "chi-square", "chi.square"))) > 0L) {
    test[target.idx] <- "standard"
  }
  if (length(target.idx <- which(test %in%
    c(
      "satorra", "sb", "satorra.bentler", "satorra-bentler",
      "m.adjusted", "m", "mean.adjusted", "mean-adjusted"
    ))) > 0L) {
    test[target.idx] <- "satorra.bentler"
  }
  if (length(target.idx <- which(test %in%
    c("yuan", "yb", "yuan.bentler", "yuan-bentler"))) > 0L) {
    test[target.idx] <- "yuan.bentler"
  }
  if (length(target.idx <- which(test %in%
    c(
      "yuan.bentler.mplus", "yuan-bentler.mplus",
      "yuan-bentler-mplus"
    ))) > 0L) {
    test[target.idx] <- "yuan.bentler.mplus"
  }
  if (length(target.idx <- which(test %in%
    c(
      "mean.var.adjusted", "mean-var-adjusted", "mv", "second.order",
      "satterthwaite", "mv.adjusted"
    ))) > 0L) {
    test[target.idx] <- "mean.var.adjusted"
  }
  if (length(target.idx <- which(test %in%
    c(
      "mplus6", "scale.shift", "scaled.shifted",
      "scaled-shifted"
    ))) > 0L) {
    test[target.idx] <- "scaled.shifted"
  }
  if (length(target.idx <- which(test %in%
    c("bootstrap", "boot", "bollen.stine", "bollen-stine"))) > 0L) {
    test[target.idx] <- "bollen.stine"
  }
  if (length(target.idx <- which(test %in%
    c(
      "browne", "residual", "residuals", "browne.residual",
      "browne.residuals", "residual-based", "residual.based",
      "browne.residuals.adf", "browne.residual.adf"
    ))) > 0L) {
    test[target.idx] <- "browne.residual.adf"
  }
  if (length(target.idx <- which(test %in%
    c("browne.residuals.nt", "browne.residual.nt"))) > 0L) {
    test[target.idx] <- "browne.residual.nt"
  }
  if (length(target.idx <- which(test %in%
    c("browne.residual.adf.model"))) > 0L) {
    test[target.idx] <- "browne.residual.adf.model"
  }
  if (length(target.idx <- which(test %in%
    c(
      "browne.residuals.nt.model", "browne.residual.nt.model",
      "rls", "browne.rls", "nt.rls", "nt-rls", "ntrls"
    ))) > 0L) {
    test[target.idx] <- "browne.residual.nt.model"
  }


  # check?
  if (check) {
    # report unknown values
    bad.idx <- which(!test %in% c(
      "standard", "none", "default",
      "satorra.bentler",
      "yuan.bentler",
      "yuan.bentler.mplus",
      "mean.adjusted",
      "mean.var.adjusted",
      "scaled.shifted",
      "bollen.stine",
      "browne.residual.nt",
      "browne.residual.nt.model",
      "browne.residual.adf",
      "browne.residual.adf.model"
    ))
    if (length(bad.idx) > 0L) {
      lav_msg_stop(sprintf(
        ngettext(
          length(test[bad.idx]),
          "invalid value in %1$s argument: %2$s.",
          "invalid values in %1$s argument: %2$s."
        ),
        "test", lav_msg_view(test[bad.idx], log.sep = "none")
      ))
    }

    # if 'default' is included, length(test) must be 1
    if (length(test) > 1L && any("default" == test)) {
      lav_msg_stop(
        gettextf("if test= argument contains \"%s\", it cannot contain
                 additional elements", "default"))
    }

    # if 'none' is included, length(test) must be 1
    if (length(test) > 1L && any("none" == test)) {
      lav_msg_stop(
        gettextf("if test= argument contains \"%s\" it cannot contain
                 additional elements", "none"))
    }
  }

  # reorder: first nonscaled, then scaled
  nonscaled.idx <- which(test %in% c(
    "standard", "none", "default",
    "bollen.stine",
    "browne.residual.nt",
    "browne.residual.nt.model",
    "browne.residual.adf",
    "browne.residual.adf.model"
  ))
  scaled.idx <- which(test %in% c(
    "satorra.bentler",
    "yuan.bentler",
    "yuan.bentler.mplus",
    "mean.adjusted",
    "mean.var.adjusted",
    "scaled.shifted"
  ))
  test <- c(test[nonscaled.idx], test[scaled.idx])

  test
}

lav_model_test <- function(lavobject = NULL,
                           lavmodel = NULL,
                           lavpartable = NULL,
                           lavsamplestats = NULL,
                           lavimplied = NULL,
                           lavh1 = list(),
                           lavoptions = NULL,
                           x = NULL,
                           VCOV = NULL,
                           lavcache = NULL,
                           lavdata = NULL,
                           lavloglik = NULL,
                           test.UGamma.eigvals = FALSE) {
  # lavobject?
  if (!is.null(lavobject)) {
    lavmodel <- lavobject@Model
    lavpartable <- lav_partable_set_cache(lavobject@ParTable, lavobject@pta)
    lavsamplestats <- lavobject@SampleStats
    lavimplied <- lavobject@implied
    lavh1 <- lavobject@h1
    lavoptions <- lavobject@Options
    x <- lavobject@optim$x
    fx <- lavobject@optim[["fx"]]
    fx.group <- lavobject@optim[["fx.group"]]
    attr(fx, "fx.group") <- fx.group
    attr(x, "fx") <- fx
    VCOV <- lavobject@vcov$vcov
    lavcache <- lavobject@Cache
    lavdata <- lavobject@Data
    lavloglik <- lavobject@loglik
  }

  # backwards compatibility
  if (is.null(lavoptions$scaled.test)) {
    lavoptions$scaled.test <- "standard"
  }

  test <- test.orig <- lavoptions$test

  TEST <- list()

  # degrees of freedom (ignoring constraints)
  df <- lav_partable_df(lavpartable)

  # handle equality constraints (note: we ignore inequality constraints,
  # active or not!)
  # we use the rank of con.jac (even if the constraints are nonlinear)
  if (!lavmodel@cin.simple.only && nrow(lavmodel@con.jac) > 0L) {
    ceq.idx <- attr(lavmodel@con.jac, "ceq.idx")
    if (length(ceq.idx) > 0L) {
      neq <- qr(lavmodel@con.jac[ceq.idx, , drop = FALSE])$rank
      df <- df + neq
    }
  } else if (lavmodel@ceq.simple.only) {
    # needed??
    ndat <- lav_partable_ndat(lavpartable)
    npar <- max(lavpartable$free)
    df <- ndat - npar
  }

  # shortcut: return empty list if one of the conditions below is true:
  # - test == "none"
  # - df < 0
  # - estimator == "MML"
  if (test[1] == "none" || df < 0L || lavoptions$estimator == "MML") {
    TEST[[1]] <- list(
      test = test[1],
      stat = as.numeric(NA),
      stat.group = as.numeric(NA),
      df = df,
      refdistr = "unknown",
      pvalue = as.numeric(NA)
    )

    if (length(test) > 1L) {
      TEST[[2]] <- list(
        test = test[2],
        stat = as.numeric(NA),
        stat.group = as.numeric(NA),
        df = df,
        refdistr = "unknown",
        pvalue = as.numeric(NA)
      )
    }

    attr(TEST, "info") <-
      list(
        ngroups = lavdata@ngroups, group.label = lavdata@group.label,
        information = lavoptions$information,
        h1.information = lavoptions$h1.information,
        observed.information = lavoptions$observed.information
      )

    return(TEST)
  }


  ######################
  ## TEST == STANDARD ##
  ######################

  # get chisq value, per group

  # PML
  if (lavoptions$estimator == "PML" && test[1] != "none") {
    # attention!
    # if the thresholds are saturated (ie, nuisance parameters)
    # we should use the lav_pml_plrt() function.
    #
    # BUT, if the thresholds are structured (eg equality constraints)
    # then we MUST use the lav_pml_plrt2() function.
    #
    # This was not done automatically < 0.6-6
    #


    thresholds.structured <- FALSE
    # check
    th.idx <- which(lavpartable$op == "|")
    if (any(lavpartable$free[th.idx] == 0L)) {
      thresholds.structured <- TRUE
    }

    eq.idx <- which(lavpartable$op == "==")
    if (length(eq.idx) > 0L) {
      th.labels <- lavpartable$plabel[th.idx]
      eq.labels <- unique(c(
        lavpartable$lhs[eq.idx],
        lavpartable$rhs[eq.idx]
      ))
      if (any(th.labels %in% eq.labels)) {
        thresholds.structured <- TRUE
      }
    }

    # switch between lav_pml_plrt() and lav_pml_plrt2()
    if (thresholds.structured) {
      pml_plrt <- lav_pml_plrt2
    } else {
      pml_plrt <- lav_pml_plrt
    }

    PML <- pml_plrt(
      lavobject = NULL,
      lavmodel = lavmodel,
      lavdata = lavdata,
      lavoptions = lavoptions,
      x = x,
      VCOV = VCOV,
      lavcache = lavcache,
      lavsamplestats = lavsamplestats,
      lavpartable = lavpartable
    )
    # get chi.group from PML, since we compare to `unrestricted' model,
    # NOT observed data
    chisq.group <- PML$PLRTH0Sat.group

    # twolevel
  } else if (lavdata@nlevels > 1L) {
    if (length(lavh1) > 0L) {
      # LRT
      chisq.group <- -2 * (lavloglik$loglik.group - lavh1$logl$loglik.group)
    } else {
      chisq.group <- rep(as.numeric(NA), lavdata@ngroups)
    }
  } else if (lavdata@missing == "ml" && any(lavdata@Mp[[1]]$coverage == 0)) {
    if (length(lavh1) > 0L) {
      chisq.group <- -2 * (lavloglik$loglik.group - lavh1$logl$loglik.group)
    } else {
      chisq.group <- rep(as.numeric(NA), lavdata@ngroups)
    }
  } else if (lavoptions$estimator %in% c("IV")) {
    # no 'standard' chi-square statistic
    chisq.group <- rep(as.numeric(NA), lavdata@ngroups)
  } else {
    # get fx.group
    fx <- attr(x, "fx")
    fx.group <- attr(fx, "fx.group")

    # always compute `standard' test statistic
    ## FIXME: the NFAC is now implicit in the computation of fx...
    NFAC <- 2 * unlist(lavsamplestats@nobs)
    if (lavoptions$estimator == "ML" && lavoptions$likelihood == "wishart") {
      # first divide by two
      NFAC <- NFAC / 2
      NFAC <- NFAC - 1
      NFAC <- NFAC * 2
    } else if (lavoptions$estimator == "DLS") {
      NFAC <- NFAC / 2
      NFAC <- NFAC - 1
      NFAC <- NFAC * 2
    }

    chisq.group <- fx.group * NFAC
  }

  # check for negative values
  chisq.group[chisq.group < 0] <- 0.0

  # global test statistic
  chisq <- sum(chisq.group)

  # reference distribution: always chi-square, except for the
  # non-robust version of ULS and PML
  if (lavoptions$estimator %in% c("ULS", "DWLS", "PML")) {
    refdistr <- "unknown"
    pvalue <- as.numeric(NA)
  } else {
    refdistr <- "chisq"

    # pvalue  ### FIXME: what if df=0? NA? or 1? or 0?
    # this is not trivial, since
    # 1 - pchisq(0, df=0) = 1
    # but
    # 1 - pchisq(0.00000000001, df=0) = 0
    # and
    # 1 - pchisq(0, df=0, ncp=0) = 0
    #
    # This is due to different definitions of limits (from the left,
    # or from the right)
    #
    # From 0.5-17 onwards, we will use NA if df=0, to be consistent
    if (df == 0) {
      pvalue <- as.numeric(NA)
    } else {
      pvalue <- 1 - pchisq(chisq, df)
    }
  }

  TEST[["standard"]] <- list(
    test = "standard",
    stat = chisq,
    stat.group = chisq.group,
    df = df,
    refdistr = refdistr,
    pvalue = pvalue
  )

  if (length(test) == 1L && test == "standard") {
    # we are done
    attr(TEST, "info") <-
      list(
        ngroups = lavdata@ngroups, group.label = lavdata@group.label,
        information = lavoptions$information,
        h1.information = lavoptions$h1.information,
        observed.information = lavoptions$observed.information
      )
    return(TEST)
  } else {
    # strip 'standard' from test list
    if (length(test) > 1L) {
      standard.idx <- which(test == "standard")
      if (length(standard.idx) > 0L) {
        test <- test[-standard.idx]
      }
    }
  }




  ######################
  ## additional tests ## # new in 0.6-5
  ######################

  for (this.test in test) {
    if (lavoptions$estimator == "PML") {
      if (this.test == "mean.var.adjusted") {
        LABEL <- "mean+var adjusted correction (PML)"
        TEST[[this.test]] <-
          list(
            test = this.test,
            stat = PML$stat,
            stat.group = TEST[[1]]$stat.group * PML$scaling.factor,
            df = PML$df,
            pvalue = PML$p.value,
            scaling.factor = 1 / PML$scaling.factor,
            label = LABEL,
            shift.parameter = as.numeric(NA),
            trace.UGamma = as.numeric(NA),
            trace.UGamma4 = as.numeric(NA),
            trace.UGamma2 = as.numeric(NA),
            UGamma.eigenvalues = as.numeric(NA)
          )
      } else {
        lav_msg_warn(gettextf("test option %s not available for estimator PML",
                              this.test))
      }
    } else if (this.test %in% c(
      "browne.residual.adf",
      "browne.residual.adf.model",
      "browne.residual.nt",
      "browne.residual.nt.model"
    )) {
      ADF <- TRUE
      if (this.test %in% c(
        "browne.residual.nt",
        "browne.residual.nt.model"
      )) {
        ADF <- FALSE
      }
      model.based <- FALSE
      if (this.test %in% c(
        "browne.residual.adf.model",
        "browne.residual.nt.model"
      )) {
        model.based <- TRUE
      }

      out <- lav_test_browne(
        lavobject = NULL,
        lavdata = lavdata,
        lavsamplestats = lavsamplestats,
        lavmodel = lavmodel,
        lavpartable = lavpartable,
        lavoptions = lavoptions,
        lavh1 = lavh1,
        lavimplied = lavimplied,
        ADF = ADF,
        model.based = model.based
      )
      TEST[[this.test]] <- out
    } else if (this.test %in% c(
      "satorra.bentler",
      "mean.var.adjusted",
      "scaled.shifted"
    )) {
      # which test statistic shall we scale?
      unscaled.TEST <- TEST[[1]]
      if (lavoptions$scaled.test != "standard") {
        idx <- which(test.orig == lavoptions$scaled.test)
        if (length(idx) > 0L) {
          unscaled.TEST <- TEST[[idx[1]]]
        } else {
          lav_msg_warn(gettextf(
            "scaled.test [%1$s] not found among available (non scaled) tests:
            %2$s. Using standard test instead.",
            lavoptions$scaled.test, lav_msg_view(test)))
        }
      }

      out <- lav_test_satorra_bentler(
        lavobject = NULL,
        lavsamplestats = lavsamplestats,
        lavmodel = lavmodel,
        lavimplied = lavimplied,
        lavdata = lavdata,
        lavoptions = lavoptions,
        TEST.unscaled = unscaled.TEST,
        E.inv = attr(VCOV, "E.inv"),
        Delta = attr(VCOV, "Delta"),
        WLS.V = attr(VCOV, "WLS.V"),
        Gamma = attr(VCOV, "Gamma"),
        test = this.test,
        method = "original", # since 0.6-13
        return.ugamma = FALSE
      )
      TEST[[this.test]] <- out[[this.test]]
    } else if (this.test %in% c(
      "yuan.bentler",
      "yuan.bentler.mplus"
    )) {
      # which test statistic shall we scale?
      unscaled.TEST <- TEST[[1]]
      if (lavoptions$scaled.test != "standard") {
        idx <- which(test.orig == lavoptions$scaled.test)
        if (length(idx) > 0L) {
          unscaled.TEST <- TEST[[idx[1]]]
        } else {
          lav_msg_warn(gettextf(
            "scaled.test [%1$s] not found among available (non scaled) tests:
            %2$s. Using standard test instead.",
            lavoptions$scaled.test, lav_msg_view(test)))
          }
      }

      out <- lav_test_yuan_bentler(
        lavobject = NULL,
        lavsamplestats = lavsamplestats,
        lavmodel = lavmodel,
        lavdata = lavdata,
        lavimplied = lavimplied,
        lavh1 = lavh1,
        lavoptions = lavoptions,
        TEST.unscaled = unscaled.TEST,
        E.inv = attr(VCOV, "E.inv"),
        B0.group = attr(VCOV, "B0.group"),
        test = this.test,
        mimic = lavoptions$mimic,
        # method         = "default",
        return.ugamma = FALSE
      )
      TEST[[this.test]] <- out[[this.test]]
    } else if (this.test == "bollen.stine") {
      # check if we have bootstrap lavdata
      BOOT.TEST <- attr(VCOV, "BOOT.TEST")
      if (is.null(BOOT.TEST)) {
        if (!is.null(lavoptions$bootstrap)) {
          R <- lavoptions$bootstrap
        } else {
          R <- 1000L
        }
        boot.type <- "bollen.stine"
        BOOT.TEST <-
          lav_bootstrap_internal(
            object = NULL,
            lavmodel. = lavmodel,
            lavsamplestats. = lavsamplestats,
            lavpartable. = lavpartable,
            lavoptions. = lavoptions,
            lavdata. = lavdata,
            R = R,
            type = boot.type,
            FUN = "test"
          )

        # new in 0.6-12: always warn for failed and nonadmissible
        error.idx <- attr(BOOT.TEST, "error.idx")
        nfailed <- length(attr(BOOT.TEST, "error.idx")) # zero if NULL
        if (nfailed > 0L) {
          lav_msg_warn(gettextf(
            "%d bootstrap runs failed or did not converge.", nfailed
          ))
        }

        notok <- length(attr(BOOT.TEST, "nonadmissible")) # zero if NULL
        if (notok > 0L) {
          lav_msg_warn(gettextf(
            "%d bootstrap runs resulted in nonadmissible solutions.", notok
          ))
        }

        if (length(error.idx) > 0L) {
          # new in 0.6-13: we must still remove them!
          BOOT.TEST <- BOOT.TEST[-error.idx, , drop = FALSE]
          # this also drops the attributes
        }

        BOOT.TEST <- drop(BOOT.TEST)
      }

      # bootstrap p-value
      boot.larger <- sum(BOOT.TEST > chisq)
      boot.length <- length(BOOT.TEST)
      pvalue.boot <- boot.larger / boot.length

      TEST[[this.test]] <- list(
        test = this.test,
        stat = chisq,
        stat.group = chisq.group,
        df = df,
        pvalue = pvalue.boot,
        refdistr = "bootstrap",
        boot.T = BOOT.TEST,
        boot.larger = boot.larger,
        boot.length = boot.length
      )
    }
  } # additional tests

  # add additional information as an attribute, needed for independent
  # printing
  attr(TEST, "info") <-
    list(
      ngroups = lavdata@ngroups, group.label = lavdata@group.label,
      information = lavoptions$information,
      h1.information = lavoptions$h1.information,
      observed.information = lavoptions$observed.information
    )

  TEST
}

lav_update_test_custom_h1 <- function(lav_obj_h0, lav_obj_h1) {
  stopifnot(inherits(lav_obj_h0, "lavaan"))
  stopifnot(inherits(lav_obj_h1, "lavaan"))

  ## this breaks if object not nested in (df >=) h1, so check df
  stopifnot(lav_obj_h0@test[[1]]$df >= lav_obj_h1@test[[1]]$df)

  ## remove any other (potentially hidden) h1 model from BOTH objects
  lav_obj_h0@external$h1.model <- NULL
  lav_obj_h1@external$h1.model <- NULL

  ## save old @test slot as template
  ## (so the @test[[1]]$df don't change while looping over tests to update)
  newTEST <- lav_obj_h0@test

  ## assemble a call to lavTestLRT()
  lrtCallTemplate <- list(quote(lavTestLRT), object = quote(lav_obj_h0),
                          quote(lav_obj_h1)) # in ...

  ## can only update tests available in both objects
  testNames0 <- names(lav_obj_h0@test)
  testNames1 <- names(lav_obj_h1@test)
  testNames <- intersect(testNames0, testNames1)

  ## loop over those tests
  for (tn in testNames) {
    lrtCall <- lrtCallTemplate
    ## conditional arguments:
    if (tn == "standard") {
      lrtCall$method <- "standard"
    } else if (tn %in% c("scaled.shifted","mean.var.adjusted")) {
      if (lav_obj_h0@Options$estimator == "PML") {
        lrtCall$method <- "mean.var.adjusted.PLRT"
      } else {
        lrtCall$method <- "satorra.2000"
      }
      lrtCall$scaled.shifted <- tn == "scaled.shifted"
    } else if (tn %in% c("satorra.bentler",
                         "yuan.bentler","yuan.bentler.mplus")) {
      lrtCall$test <- tn
    } else if (grepl(pattern = "browne", x = tn)) {
      lrtCall$type <- tn
    } else {
      #TODO?
      #   - if (tn %in% c("bootstrap", "bollen.stine")) next
      #   - any other possibilities in @test?
    }

    ## get new test
    if (lav_obj_h0@test[[1]]$df == lav_obj_h1@test[[1]]$df) {
      ## suppress warning about == df
      ANOVA <- suppressWarnings(eval(as.call(lrtCall)))
    } else {
      ## maybe some other informative warning would be important to see
      ANOVA <- eval(as.call(lrtCall))
    }


    ## replace old @test[[tn]] values
    newTEST[[tn]]$stat.group <- NULL # avoid wrong stats in summary() header?
    newTEST[[tn]]$stat   <- ANOVA["lav_obj_h0" , "Chisq diff"]
    newTEST[[tn]]$df     <- ANOVA["lav_obj_h0" , "Df diff"   ]
    newTEST[[tn]]$pvalue <- ANOVA["lav_obj_h0" , "Pr(>Chisq)"]
    if (!is.null(newTEST[[tn]]$scaling.factor)) {
      newTEST[[tn]]$scaling.factor <- attr(ANOVA, "scale")[2] # first row is NA
    }
    if (!is.null(newTEST[[tn]]$shift.parameter)) {
      newTEST[[tn]]$shift.parameter <- attr(ANOVA, "shift")[2] # first row is NA
    } else {
      ## unless scaled.shifted, RMSEA is calculated from $standard$stat and
      ## df == sum($trace.UGamma).  Reverse-engineer from $scaling.factor:
      newTEST[[tn]]$trace.UGamma <- newTEST[[tn]]$df * newTEST[[tn]]$scaling.factor
    }
    ## should not be necessary to replace $trace.UGamma2
    ## nor to replace $scaling.factor.h0/h1
  } # end loop over tests

  ## assign updated @test slot and return
  lav_obj_h0@test <- newTEST
  lav_obj_h0
}



# the multivariate normal distribution, unrestricted (h1)
# - everything is evalued under the MLEs: Mu = ybar, Sigma = S

# 1) loglikelihood h1 (from raw data, or sample statistics)
# 4) hessian h1 around MLEs
# 5) information h1 (restricted Sigma/mu)
#    5a: (unit)    expected information h1 (A1 = Gamma.NT^{-1})
#    5b: (unit)    observed information h1 (A1 = Gamma.NT^{-1})
#    5c: (unit) first.order information h1 (B1 = A1 %*% Gamma %*% A1)
# 6) inverted information h1 mu + vech(Sigma)
#    6a: (unit) inverted expected information (A1.inv = Gamma.NT)
#    6b: (unit) inverted observed information (A1.inv = Gamma.NT)
#    6c: (unit) inverted first-order information (B1.inv)
# 7) ACOV h1 mu + vech(Sigma)
#    7a: 1/N * Gamma.NT
#    7b: 1/N * Gamma.NT
#    7c: 1/N * (Gamma.NT * Gamma^{-1} * Gamma.NT)
#    7d: 1/N * Gamma (sandwich)


# YR 25 Mar 2016: first version
# YR 19 Jan 2017: added 6) + 7)
# YR 04 Jan 2020: adjust for sum(wt) != N
# YR 22 Jul 2022: adding correlation= argument for information_expected
#                 (only for catml; not used if correlation = TRUE!)

# 1. log-likelihood h1

# 1a: input is raw data
lav_mvnorm_h1_loglik_data <- function(
    Y = NULL,
    x.idx = integer(0L),
    casewise = FALSE,
    wt = NULL,
    Sinv.method = "eigen") {

  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }
  P <- NCOL(Y)

  # sample statistics
  if (!is.null(wt)) {
    out <- stats::cov.wt(Y, wt = wt, method = "ML")
    sample.mean <- out$center
    sample.cov <- out$cov
  } else {
    sample.mean <- base::.colMeans(Y, m = N, n = P)
    sample.cov <- lav_matrix_cov(Y)
  }

  if (casewise) {
    LOG.2PI <- log(2 * pi)

    # invert sample.cov
    if (Sinv.method == "chol") {
      cS <- chol(sample.cov)
      icS <- backsolve(cS, diag(P))
      Yc <- t(t(Y) - sample.mean)
      DIST <- rowSums((Yc %*% icS)^2)
      logdet <- -2 * sum(log(diag(icS)))
    } else {
      sample.cov.inv <- lav_matrix_symmetric_inverse(
        S = sample.cov,
        logdet = TRUE, Sinv.method = Sinv.method
      )
      logdet <- attr(sample.cov.inv, "logdet")
      # mahalanobis distance
      Yc <- t(t(Y) - sample.mean)
      DIST <- rowSums(Yc %*% sample.cov.inv * Yc)
    }

    loglik <- -(P * LOG.2PI + logdet + DIST) / 2

    # weights
    if (!is.null(wt)) {
      loglik <- loglik * wt
    }
  } else {
    # invert sample.cov
    sample.cov.inv <- lav_matrix_symmetric_inverse(
      S = sample.cov,
      logdet = TRUE, Sinv.method = Sinv.method
    )
    logdet <- attr(sample.cov.inv, "logdet")

    loglik <-
      lav_mvnorm_h1_loglik_samplestats(
        sample.cov.logdet = logdet,
        sample.nvar = P,
        sample.nobs = N
      )
  }

  # fixed.x?
  if (length(x.idx) > 0L) {
    loglik.x <- lav_mvnorm_h1_loglik_data(
      Y = Y[, x.idx, drop = FALSE],
      wt = wt, x.idx = integer(0L),
      casewise = casewise,
      Sinv.method = Sinv.method
    )
    # subtract logl.X
    loglik <- loglik - loglik.x
  }

  loglik
}



# 1b: input are sample statistics only (logdet, N and P)
lav_mvnorm_h1_loglik_samplestats <- function(
    sample.cov.logdet = NULL,
    sample.nvar = NULL,
    sample.nobs = NULL,
    # or
    sample.cov = NULL,
    x.idx = integer(0L),
    x.cov = NULL,
    Sinv.method = "eigen") {

  if (is.null(sample.nvar)) {
    P <- NCOL(sample.cov)
  } else {
    P <- sample.nvar # number of variables
  }

  N <- sample.nobs
  stopifnot(!is.null(P), !is.null(N))

  LOG.2PI <- log(2 * pi)

  # all we need is the logdet
  if (is.null(sample.cov.logdet)) {
    sample.cov.inv <- lav_matrix_symmetric_inverse(
      S = sample.cov,
      logdet = TRUE, Sinv.method = Sinv.method
    )
    logdet <- attr(sample.cov.inv, "logdet")
  } else {
    logdet <- sample.cov.logdet
  }

  loglik <- -N / 2 * (P * LOG.2PI + logdet + P)

  # fixed.x?
  if (length(x.idx) > 0L) {
    if (is.null(sample.cov)) {
      if (is.null(x.cov)) {
        lav_msg_stop(gettext(
          "when x.idx is not empty, we need sample.cov or x.cov"
        ))
      } else {
        sample.cov.x <- x.cov
      }
    } else {
      sample.cov.x <- sample.cov[x.idx, x.idx, drop = FALSE]
    }

    loglik.x <-
      lav_mvnorm_h1_loglik_samplestats(
        sample.cov = sample.cov.x,
        sample.nobs = sample.nobs,
        x.idx = integer(0L),
        Sinv.method = Sinv.method
      )
    # subtract logl.X
    loglik <- loglik - loglik.x
  }

  loglik
}


# 4. hessian of logl (around MLEs of Mu and Sigma)

# 4a: hessian logl Mu and vech(Sigma) from raw data
lav_mvnorm_h1_logl_hessian_data <- function(
    Y = NULL,
    wt = NULL,
    x.idx = integer(0L),
    Sinv.method = "eigen",
    sample.cov.inv = NULL,
    meanstructure = TRUE) {

  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }

  # observed information
  observed <- lav_mvnorm_h1_information_observed_data(
    Y = Y, wt = wt,
    x.idx = x.idx,
	Sinv.method = Sinv.method,
    sample.cov.inv = sample.cov.inv,
    meanstructure = meanstructure
  )

  -N * observed
}

# 4b: hessian Mu and vech(Sigma) from samplestats
lav_mvnorm_h1_logl_hessian_samplestats <- function(
    sample.mean = NULL, # unused!
    sample.cov = NULL,
    sample.nobs = NULL,
    x.idx = integer(0L),
    Sinv.method = "eigen",
    sample.cov.inv = NULL,
    meanstructure = TRUE) {

  N <- sample.nobs

  # observed information
  observed <- lav_mvnorm_h1_information_observed_samplestats(
    sample.mean = sample.mean, sample.cov = sample.cov,
    x.idx = x.idx,
    Sinv.method = Sinv.method, sample.cov.inv = sample.cov.inv,
    meanstructure = meanstructure
  )

  -N * observed
}



# 5) Information h1 (note: expected == observed if data is complete!)

# 5a: unit expected information h1
lav_mvnorm_h1_information_expected <- function(
    Y = NULL,
    wt = NULL,
    sample.cov = NULL,
    x.idx = integer(0L),
    Sinv.method = "eigen",
    sample.cov.inv = NULL,
    meanstructure = TRUE,
	correlation = FALSE) {

  if (is.null(sample.cov.inv)) {
    if (is.null(sample.cov)) {
      if (is.null(wt)) {
        sample.mean <- base::.colMeans(Y, m = NROW(Y), n = NCOL(Y))
        sample.cov <- lav_matrix_cov(Y)
      } else {
        out <- stats::cov.wt(Y, wt = wt, method = "ML")
        sample.cov <- out$cov
      }
    }

    # invert sample.cov
    sample.cov.inv <- lav_matrix_symmetric_inverse(
      S = sample.cov,
      logdet = FALSE, Sinv.method = Sinv.method
    )
  }

  I11 <- sample.cov.inv
  if(correlation) {
    # if (lav_use_lavaanC()) {
    #   I22 <- lavaanC::m_kronecker_dup_cor_pre_post(sample.cov.inv,
    #                                                multiplicator = 0.5)
    # } else {
      I22 <- 0.5 * lav_matrix_duplication_cor_pre_post(sample.cov.inv %x%
                                                     sample.cov.inv)
    # }
  } else {
    # if (lav_use_lavaanC()) {
    #   I22 <- lavaanC::m_kronecker_dup_pre_post(sample.cov.inv,
    #                                            multiplicator = 0.5)
    # } else {
      I22 <- 0.5 * lav_matrix_duplication_pre_post(sample.cov.inv %x%
                                                   sample.cov.inv)
    # }
  }

  # fixed.x?
  if (length(x.idx) > 0L) {
    pstar.x <- lav_matrix_vech_which_idx(
      n = NCOL(sample.cov.inv), idx = x.idx
    )
    I22[pstar.x, ] <- 0
    I22[, pstar.x] <- 0
  }

  if (meanstructure) {
    # fixed.x?
    if (length(x.idx) > 0L) {
      I11[x.idx, ] <- 0
      I11[, x.idx] <- 0
    }
    out <- lav_matrix_bdiag(I11, I22)
  } else {
    out <- I22
  }

  out
}

# 5b: unit observed information h1
lav_mvnorm_h1_information_observed_data <- function(
    Y = NULL,
    wt = NULL,
    x.idx = integer(0L),
    Sinv.method = "eigen",
    sample.cov.inv = NULL,
    meanstructure = TRUE) {

  lav_mvnorm_h1_information_expected(
    Y = Y, Sinv.method = Sinv.method,
    wt = wt, x.idx = x.idx,
    sample.cov.inv = sample.cov.inv,
    meanstructure = meanstructure
  )
}

# 5b-bis: observed information h1 from sample statistics
lav_mvnorm_h1_information_observed_samplestats <- function(
    sample.mean = NULL, # unused!
    sample.cov = NULL,
    x.idx = integer(0L),
    Sinv.method = "eigen",
    sample.cov.inv = NULL,
    meanstructure = TRUE) {

  if (is.null(sample.cov.inv)) {
    # invert sample.cov
    sample.cov.inv <- lav_matrix_symmetric_inverse(
      S = sample.cov,
      logdet = FALSE, Sinv.method = Sinv.method
    )
  }

  I11 <- sample.cov.inv
  # fixed.x?
  if (length(x.idx) > 0L) {
    I11[x.idx, ] <- 0
    I11[, x.idx] <- 0
  }

  # if (lav_use_lavaanC()) {
  #   I22 <- lavaanC::m_kronecker_dup_pre_post(sample.cov.inv,
  #                                            multiplicator = 0.5)
  # } else {
    I22 <- 0.5 * lav_matrix_duplication_pre_post(sample.cov.inv %x%
    sample.cov.inv)
  # }

  # fixed.x?
  if (length(x.idx) > 0L) {
    pstar.x <- lav_matrix_vech_which_idx(
      n = NCOL(sample.cov.inv), idx = x.idx
    )
    I22[pstar.x, ] <- 0
    I22[, pstar.x] <- 0
  }

  if (meanstructure) {
    out <- lav_matrix_bdiag(I11, I22)
  } else {
    out <- I22
  }

  out
}

# 5c: unit first-order information h1
#     note: first order information h1 == A1 %*% Gamma %*% A1
#           (where A1 = obs/exp information h1)
lav_mvnorm_h1_information_firstorder <- function(
    Y = NULL,
    wt = NULL,
    sample.cov = NULL,
    x.idx = integer(0L),
    cluster.idx = NULL,
    Sinv.method = "eigen",
    sample.cov.inv = NULL,
    Gamma = NULL,
    meanstructure = TRUE) {

  if (!is.null(wt)) {
    out <- stats::cov.wt(Y, wt = wt, method = "ML")
    res <- lav_mvnorm_information_firstorder(
      Y = Y, wt = wt,
      cluster.idx = cluster.idx,
      Mu = out$center, Sigma = out$cov, x.idx = x.idx,
      meanstructure = meanstructure
    )
    return(res)
  }

   # sample.cov.inv
  if (is.null(sample.cov.inv)) {
    # invert sample.cov
    if (is.null(sample.cov)) {
      sample.mean <- base::.colMeans(Y, m = NROW(Y), n = NCOL(Y))
      sample.cov <- lav_matrix_cov(Y)
    }
    sample.cov.inv <- lav_matrix_symmetric_inverse(
      S = sample.cov,
      logdet = FALSE, Sinv.method = Sinv.method
    )
  }

  # question: is there any benefit computing Gamma/A1 instead of just
  # calling lav_mvnorm_information_firstorder()?
  # answer (2014): probably not; it is just reassuring that the expression
  # J = A1 %*% Gamma %*% A1 seems to hold

  # Gamma
  # FIXME: what about the 'unbiased = TRUE' option?
  if (is.null(Gamma)) {
    if (length(x.idx) > 0L) {
      Gamma <- lav_samplestats_Gamma(Y,
        x.idx = x.idx, fixed.x = TRUE,
        cluster.idx = cluster.idx,
        meanstructure = meanstructure
      )
    } else {
      Gamma <- lav_samplestats_Gamma(Y,
        meanstructure = meanstructure,
        cluster.idx = cluster.idx
      )
    }
  }

  # sample.cov.inv
  if (is.null(sample.cov.inv)) {
    # invert sample.cov
    if (is.null(sample.cov)) {
      sample.mean <- base::.colMeans(Y, m = NROW(Y), n = NCOL(Y))
      sample.cov <- lav_matrix_cov(Y)
    }
    sample.cov.inv <- lav_matrix_symmetric_inverse(
      S = sample.cov,
      logdet = FALSE, Sinv.method = Sinv.method
    )
  }

  # A1
  A1 <- lav_mvnorm_h1_information_expected(
    Y = Y, Sinv.method = Sinv.method,
    sample.cov.inv = sample.cov.inv,
    x.idx = x.idx,
    meanstructure = meanstructure
  )

  A1 %*% Gamma %*% A1
}

# 6) inverted information h1 mu + vech(Sigma) (not used?)

#    6a: (unit) inverted expected information (A1.inv = Gamma.NT)
#    6b: (unit) inverted observed information (A1.inv = Gamma.NT)

lav_mvnorm_h1_inverted_information_expected <-
lav_mvnorm_h1_inverted_information_observed <- function(
  Y = NULL,
  wt = NULL,
  sample.cov = NULL,
  x.idx = integer(0L)) {

  # sample.cov
  if (is.null(sample.cov)) {
    if (is.null(wt)) {
      sample.mean <- base::.colMeans(Y, m = NROW(Y), n = NCOL(Y))
      sample.cov <- lav_matrix_cov(Y)
    } else {
      out <- stats::cov.wt(Y, wt = wt, method = "ML")
      sample.cov <- out$cov
    }
  }

  if (length(x.idx) > 0L) {
    Gamma.NT <- lav_samplestats_Gamma_NT(
      Y = Y, wt = wt, x.idx = x.idx,
      COV = sample.cov,
      meanstructure = TRUE,
      fixed.x = TRUE
    )
  } else {
    I11 <- sample.cov
    # if (lav_use_lavaanC()) {
    #   I22 <- lavaanC::m_kronecker_dup_ginv_pre_post(sample.cov,
    #                                                 multiplicator = 2.0)
    # } else {
      I22 <- 2 * lav_matrix_duplication_ginv_pre_post(sample.cov %x% sample.cov)
    # }
    Gamma.NT <- lav_matrix_bdiag(I11, I22)
  }

  Gamma.NT
}

#    6c: (unit) inverted first-order information (B1.inv) (not used?)
#        J1.inv = Gamma.NT %*% solve(Gamma) %*%  Gamma.NT
#
lav_mvnorm_h1_inverted_information_firstorder <- function(
    Y = NULL,
    wt = NULL,
    sample.cov = NULL,
    x.idx = integer(0L),
    Sinv.method = "eigen",
    sample.cov.inv = NULL,
    Gamma = NULL) {

  # lav_samplestats_Gamma() has no wt argument (yet)
  if (!is.null(wt)) {
    lav_msg_stop(gettext("function not supported if wt is not NULL"))
  }

  # Gamma
  # what about the 'unbiased = TRUE' option?
  if (is.null(Gamma)) {
    if (length(x.idx) > 0L) {
      Gamma <- lav_samplestats_Gamma(Y,
        x.idx = x.idx, fixed.x = TRUE,
        meanstructure = TRUE
      )
    } else {
      Gamma <- lav_samplestats_Gamma(Y, meanstructure = TRUE)
    }
  }

  # Gamma.NT
  Gamma.NT <-
    lav_mvnorm_h1_inverted_information_expected(
      Y = Y,
      sample.cov = sample.cov,
      x.idx = x.idx
    )
  if (length(x.idx) > 0L) {
    # FIXME: surely there is better way
    out <- Gamma.NT %*% MASS::ginv(Gamma) %*% Gamma.NT
  } else {
    out <- Gamma.NT %*% solve(Gamma, Gamma.NT)
  }

  out
}


# 7) ACOV h1 mu + vech(Sigma) (not used?)

#    7a: 1/N * Gamma.NT
#    7b: 1/N * Gamma.NT
lav_mvnorm_h1_acov_expected <-
lav_mvnorm_h1_acov_observed <- function(
    Y = NULL,
    wt = NULL,
    sample.cov = NULL,
    x.idx = integer(0L)) {

  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }

  Gamma.NT <-
    lav_mvnorm_h1_inverted_information_expected(
      Y = Y,
      wt = wt,
      sample.cov = sample.cov,
      x.idx = x.idx
    )

  (1 / N) * Gamma.NT
}

#    7c: 1/N * (Gamma.NT * Gamma^{-1} * Gamma.NT)
lav_mvnorm_h1_acov_firstorder <- function(
    Y = NULL,
    wt = NULL,
    sample.cov = NULL,
    Sinv.method = "eigen",
    x.idx = integer(0L),
    sample.cov.inv = NULL,
    Gamma = NULL) {

  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }

  J1.inv <- lav_mvnorm_h1_inverted_information_firstorder(
    Y = Y, wt = wt,
    sample.cov = sample.cov,
    x.idx = x.idx, Sinv.method = Sinv.method,
    sample.cov.inv = sample.cov.inv, Gamma = Gamma
  )

  (1 / N) * J1.inv
}

#    7d: 1/N * Gamma (sandwich)
lav_mvnorm_h1_acov_sandwich <- function(
    Y = NULL,
    wt = NULL,
    sample.cov = NULL,
    x.idx = integer(0L),
    Gamma = NULL) {

  # lav_samplestats_Gamma() has no wt argument (yet)
  if (!is.null(wt)) {
    lav_msg_stop(gettext("function not supported if wt is not NULL"))
  }

  # if(!is.null(wt)) {
  #    N <- sum(wt)
  # } else {
  N <- NROW(Y)
  # }

  # Gamma
  if (is.null(Gamma)) {
    if (length(x.idx) > 0L) {
      Gamma <- lav_samplestats_Gamma(Y,
        x.idx = x.idx, fixed.x = TRUE,
        meanstructure = TRUE
      )
    } else {
      Gamma <- lav_samplestats_Gamma(Y, meanstructure = TRUE)
    }
  }

  (1 / N) * Gamma
}

# All code below is written by Myrsini Katsikatsou (Feb 2015)

# The following function refers to PLRT for nested models and equality constraints.
# Namely, it is developed to test either of the following hypotheses:
# a) H0 states that some parameters are equal to 0
# b) H0 states that some parameters are equal to some others.
# Note that for the latter I haven't checked if it is ok when equality constraints
# are imposed on parameters that refer to different groups in a multi-group
# analysis. All the code below has been developed for a single-group analysis.

# Let fit_objH0 and fit_objH1 be the outputs of lavaan() function when we fit
# a model under the null hypothesis and under the alternative, respectively.
# The argument equalConstr is logical (T/F) and it is TRUE if  equality constraints
# are imposed on subsets of the parameters.

# The main idea of the code below is that we consider the parameter vector
# under the alternative H1 evaluated at the values derived under H0 and for these
# values we should evaluate the Hessian, the variability matrix (denoted by J)
# and Godambe matrix.

lav_pml_test_plrt <- function(fit_objH0, fit_objH1) {
  # sanity check, perhaps we misordered H0 and H1 in the function call??
  if (fit_objH1@test[[1]]$df > fit_objH0@test[[1]]$df) {
    tmp <- fit_objH0
    fit_objH0 <- fit_objH1
    fit_objH1 <- tmp
  }

  # check if we have equality constraints
  if (fit_objH0@Model@eq.constraints) {
    equalConstr <- TRUE
  } else {
    equalConstr <- FALSE
  }

  nsize <- fit_objH0@SampleStats@ntotal
  PLRT <- 2 * (fit_objH1@optim$logl - fit_objH0@optim$logl)

  # create a new object 'objH1_h0': the object 'H1', but where
  # the parameter values are from H0
  objH1_h0 <- lav_test_diff_m10(m1 = fit_objH1, m0 = fit_objH0, test = FALSE)

  # EqMat # YR: from 0.6-2, use lav_test_diff_A() (again)
  #             this should allow us to test models that are
  #             nested in the covariance matrix sense, but not
  #             in the parameter (table) sense
  EqMat <- lav_test_diff_A(m1 = fit_objH1, m0 = fit_objH0)
  if (objH1_h0@Model@eq.constraints) {
    EqMat <- EqMat %*% t(objH1_h0@Model@eq.constraints.K)
  }
  # if (equalConstr == TRUE) {
  #    EqMat <- fit_objH0@Model@ceq.JAC
  # } else {
  #    PT0 <- fit_objH0@ParTable
  #    PT1 <- fit_objH1@ParTable
  #    h0.par.idx <- which(PT1$free > 0 & !(PT0$free > 0))
  #    tmp.ind <- PT1$free[ h0.par.idx ]
  #
  #    no.par0 <- length(tmp.ind)
  #    tmp.ind2 <- cbind(1:no.par0, tmp.ind ) # matrix indices
  #    EqMat <- matrix(0, nrow=no.par0, ncol=fit_objH1@Model@nx.free)
  #    EqMat[tmp.ind2] <- 1
  # }

  # DEBUG YR -- eliminate the constraints also present in H1
  #          -- if we do this, there is no need to use MASS::ginv later
  # JAC0 <- fit_objH0@Model@ceq.JAC
  # JAC1 <- fit_objH1@Model@ceq.JAC
  # unique.idx <- which(apply(JAC0, 1, function(x) {
  #                    !any(apply(JAC1, 1, function(y) { all(x == y) })) }))
  # if(length(unique.idx) > 0L) {
  #    EqMat <- EqMat[unique.idx,,drop = FALSE]
  # }

  # Observed information (= for PML, this is Hessian / N)
  Hes.theta0 <- lavTech(objH1_h0, "information.observed")

  # handle possible constraints in H1 (and therefore also in objH1_h0)
  Inv.Hes.theta0 <-
    lav_model_information_augment_invert(
      lavmodel = objH1_h0@Model,
      information = Hes.theta0,
      inverted = TRUE
    )

  # the estimated variability matrix is given (=unit information first order)
  J.theta0 <- lavTech(objH1_h0, "first.order")

  # the Inverse of the G matrix
  Inv.G <- Inv.Hes.theta0 %*% J.theta0 %*% Inv.Hes.theta0

  MInvGtM <- EqMat %*% Inv.G %*% t(EqMat)
  MinvHtM <- EqMat %*% Inv.Hes.theta0 %*% t(EqMat)
  # Inv_MinvHtM <- solve(MinvHtM)
  Inv_MinvHtM <- MASS::ginv(MinvHtM)
  tmp.prod <- MInvGtM %*% Inv_MinvHtM
  tmp.prod2 <- tmp.prod %*% tmp.prod
  sum.eig <- sum(diag(tmp.prod))
  sum.eigsq <- sum(diag(tmp.prod2))

  FSMA.PLRT <- (sum.eig / sum.eigsq) * PLRT
  adj.df <- (sum.eig * sum.eig) / sum.eigsq
  pvalue <- 1 - pchisq(FSMA.PLRT, df = adj.df)

  list(FSMA.PLRT = FSMA.PLRT, adj.df = adj.df, pvalue = pvalue)
}


# for testing: this is the 'original' (using m.el.idx and x.el.idx)
lav_pml_test_plrt2 <- function(fit_objH0, fit_objH1) {
  if (fit_objH1@test[[1]]$df > fit_objH0@test[[1]]$df) {
    tmp <- fit_objH0
    fit_objH0 <- fit_objH1
    fit_objH1 <- tmp
  }

  if (fit_objH0@Model@eq.constraints) {
    equalConstr <- TRUE
  } else {
    equalConstr <- FALSE
  }

  nsize <- fit_objH0@SampleStats@ntotal
  PLRT <- 2 * nsize * (fit_objH0@optim$fx - fit_objH1@optim$fx)
  Npar <- fit_objH1@optim$npar
  MY.m.el.idx2 <- fit_objH1@Model@m.free.idx
  MY.x.el.idx2 <- fit_objH1@Model@x.free.idx
  MY.m.el.idx <- MY.m.el.idx2
  MY.x.el.idx <- MY.x.el.idx2

  # MY.m.el.idx2 <- fit_objH1@Model@m.free.idx
  # MY.m.el.idx2 gives the POSITION index of the free parameters within each
  # parameter matrix under H1 model.
  # The index numbering restarts from 1 when we move to a new parameter matrix.
  # Within each matrix the index numbering "moves" columnwise.

  # MY.x.el.idx2 <- fit_objH1@Model@x.free.idx
  # MY.x.el.idx2 ENUMERATES the free parameters within each parameter matrix.
  # The numbering continues as we move from one parameter matrix to the next one.

  # In the case of the symmetric matrices, Theta and Psi,in some functions below
  # we need to give as input MY.m.el.idx2 and MY.x.el.idx2 after
  # we have eliminated the information about the redundant parameters
  # (those placed above the main diagonal).
  # That's why I do the following:

  # MY.m.el.idx <- MY.m.el.idx2
  # MY.x.el.idx <- MY.x.el.idx2
  # Psi, the variance - covariance matrix of factors
  # if( length(MY.x.el.idx2[[3]])!=0 & any(table(MY.x.el.idx2[[3]])>1)) {
  #  nfac <- ncol(fit_objH1@Model@GLIST$lambda) #number of factors
  #  tmp  <- matrix(c(1:(nfac^2)), nrow= nfac, ncol= nfac )
  #  tmp_keep <- tmp[lower.tri(tmp, diag=TRUE)]
  #  MY.m.el.idx[[3]] <- MY.m.el.idx[[3]][MY.m.el.idx[[3]] %in% tmp_keep]
  #  MY.x.el.idx[[3]] <- unique( MY.x.el.idx2[[3]] )
  # }

  # for Theta, the variance-covariance matrix of measurement errors
  # if( length(MY.x.el.idx2[[2]])!=0 & any(table(MY.x.el.idx2[[2]])>1)) {
  #  nvar <- fit_objH1@Model@nvar #number of indicators
  #  tmp  <- matrix(c(1:(nvar^2)), nrow= nvar, ncol= nvar )
  #  tmp_keep <- tmp[lower.tri(tmp, diag=TRUE)]
  #  MY.m.el.idx[[2]] <- MY.m.el.idx[[2]][MY.m.el.idx[[2]] %in% tmp_keep]
  #  MY.x.el.idx[[2]] <- unique( MY.x.el.idx2[[2]] )
  # }

  # below the commands to find the row-column indices of the Hessian that correspond to
  # the parameters to be tested equal to 0
  # tmp.ind contains these indices
  # MY.m.el.idx2.H0 <- fit_objH0@Model@m.free.idx
  # tmp.ind <- c()
  # for(i in 1:6) {
  #   tmp.ind <- c(tmp.ind ,
  #               MY.x.el.idx2[[i]] [!(MY.m.el.idx2[[i]]  %in%
  #                                    MY.m.el.idx2.H0[[i]] )  ]  )
  # }
  # next line added by YR
  # tmp.ind <- unique(tmp.ind)

  # YR: use partable to find which parameters are restricted in H0
  #     (this should work in multiple groups too)
  # h0.par.idx <- which(   PT.H1.extended$free[PT.H1.extended$user < 2] > 0  &
  #                     !(PT.H0.extended$free[PT.H0.extended$user < 2] > 0)   )
  # tmp.ind <- PT.H1.extended$free[ h0.par.idx ]
  # print(tmp.ind)
  if (length(MY.x.el.idx2[[3]]) != 0 & any(table(MY.x.el.idx2[[3]]) > 1)) {
    nfac <- ncol(fit_objH1@Model@GLIST$lambda)
    tmp <- matrix(c(1:(nfac * nfac)), nrow = nfac, ncol = nfac)
    tmp_keep <- tmp[lower.tri(tmp, diag = TRUE)]
    MY.m.el.idx[[3]] <- MY.m.el.idx[[3]][MY.m.el.idx[[3]] %in% tmp_keep]
    MY.x.el.idx[[3]] <- unique(MY.x.el.idx2[[3]])
  }

  if (length(MY.x.el.idx2[[2]]) != 0 & any(table(MY.x.el.idx2[[2]]) > 1)) {
    nvar <- fit_objH1@Model@nvar
    tmp <- matrix(c(1:(nvar * nvar)), nrow = nvar, ncol = nvar)
    tmp_keep <- tmp[lower.tri(tmp, diag = TRUE)]
    MY.m.el.idx[[2]] <- MY.m.el.idx[[2]][MY.m.el.idx[[2]] %in% tmp_keep]
    MY.x.el.idx[[2]] <- unique(MY.x.el.idx2[[2]])
  }
  MY.m.el.idx2.H0 <- fit_objH0@Model@m.free.idx

  tmp.ind <- c()
  for (i in 1:6) {
    tmp.ind <- c(tmp.ind, MY.x.el.idx2[[i]][!(MY.m.el.idx2[[i]] %in%
      MY.m.el.idx2.H0[[i]])])
  }
  tmp.ind <- unique(tmp.ind)

  # if the models are nested because of equality constraints among the parameters, we need
  # to construct the matrix of derivatives of function g(theta) with respect to theta
  # where g(theta) is the function that represents the equality constraints. g(theta) is
  # an rx1 vector where r are the equality constraints. In the null hypothesis
  # we test H0: g(theta)=0. The matrix of derivatives is of dimension:
  # nrows= number of free non-redundant parameters under H0, namely
  # NparH0 <- fit_objH0[[1]]@optim$npar , and ncols= number of free non-redundant
  # parameters under H1, namely NparH1 <- fit_objH0[[1]]@optim$npar.
  # The matrix of derivatives of g(theta) is composed of 0's, 1's, -1's, and
  # in the rows that refer to odd number of parameters that are equal there is one -2.
  # The 1's, -1's (and possibly -2) are the contrast coefficients of the parameters.
  # The sum of the rows should be equal to 0.
  # if(equalConstr==TRUE) {
  #    EqMat <- fit_objH0@Model@ceq.JAC
  # } else {
  #   no.par0 <- length(tmp.ind)
  #   tmp.ind2 <- cbind(1:no.par0, tmp.ind)
  #   EqMat <- matrix(0, nrow = no.par0, ncol = Npar)
  # EqMat[tmp.ind2] <- 1
  # }

  if (equalConstr == TRUE) {
    EqMat <- fit_objH0@Model@ceq.JAC
  } else {
    no.par0 <- length(tmp.ind)
    tmp.ind2 <- cbind(1:no.par0, tmp.ind)
    EqMat <- matrix(0, nrow = no.par0, ncol = Npar)
    EqMat[tmp.ind2] <- 1
  }

  obj <- fit_objH0

  # Compute the sum of the eigenvalues and the sum of the squared eigenvalues
  # so that the adjustment to PLRT can be applied.
  # Here a couple of functions (e.g. lav_pml_object_inspect_hessian) which are modifications of
  # lavaan functions (e.g. getHessian) are needed. These are defined in the end of the file.

  # the quantity below follows the same logic as getHessian of lavaan 0.5-18
  # and it actually gives N*Hessian. That's why the command following the command below.
  # NHes.theta0 <- lav_pml_object_inspect_hessian (object = obj@Model,
  #                           samplestats = obj@SampleStats ,
  #                           X = obj@Data@X ,
  #                           estimator = "PML",
  #                           lavcache = obj@Cache,
  #                           MY.m.el.idx = MY.m.el.idx,
  #                           MY.x.el.idx = MY.x.el.idx,
  #                           MY.m.el.idx2 = MY.m.el.idx2, # input for lav_pml_object_x2glist
  #                           MY.x.el.idx2 = MY.x.el.idx2, # input for lav_pml_object_x2glist
  #                           Npar = Npar,
  #                           equalConstr=equalConstr)
  NHes.theta0 <- lav_pml_object_inspect_hessian(
    object = obj@Model, samplestats = obj@SampleStats,
    X = obj@Data@X, estimator = "PML", lavcache = obj@Cache,
    MY.m.el.idx = MY.m.el.idx, MY.x.el.idx = MY.x.el.idx,
    MY.m.el.idx2 = MY.m.el.idx2, MY.x.el.idx2 = MY.x.el.idx2,
    Npar = Npar, equalConstr = equalConstr
  )
  Hes.theta0 <- NHes.theta0 / nsize
  # Inv.Hes.theta0 <- solve(Hes.theta0)
  Inv.Hes.theta0 <- MASS::ginv(Hes.theta0)

  NJ.theta0 <- lav_pml_object_information_firstorder(
    object = obj, MY.m.el.idx = MY.m.el.idx,
    MY.x.el.idx = MY.x.el.idx, equalConstr = equalConstr
  )
  J.theta0 <- NJ.theta0 / (nsize * nsize)


  Inv.G <- Inv.Hes.theta0 %*% J.theta0 %*% Inv.Hes.theta0
  MInvGtM <- EqMat %*% Inv.G %*% t(EqMat)
  MinvHtM <- EqMat %*% Inv.Hes.theta0 %*% t(EqMat)
  # Inv_MinvHtM <- solve(MinvHtM)    #!!! change names
  Inv_MinvHtM <- MASS::ginv(MinvHtM)
  tmp.prod <- MInvGtM %*% Inv_MinvHtM # !!! change names
  tmp.prod2 <- tmp.prod %*% tmp.prod
  sum.eig <- sum(diag(tmp.prod))
  sum.eigsq <- sum(diag(tmp.prod2))


  FSMA.PLRT <- (sum.eig / sum.eigsq) * PLRT
  adj.df <- (sum.eig * sum.eig) / sum.eigsq
  pvalue <- 1 - pchisq(FSMA.PLRT, df = adj.df)
  list(FSMA.PLRT = FSMA.PLRT, adj.df = adj.df, pvalue = pvalue)
}




###################################################################################
# auxiliary functions used above, they are all copy from the corresponding functions
# of lavaan where parts no needed were deleted and some parts were modified.
# I mark the modifications with comments.


# library(lavaan)

# To run an example for the functions below the following input is needed.
# obj <- fit.objH0[[i]]
# object <- obj@Model
# samplestats = obj@SampleStats
# X = obj@Data@X
# estimator = "PML"
# lavcache = obj@Cache
# MY.m.el.idx = MY.m.el.idx
# MY.x.el.idx = MY.x.el.idx
# MY.m.el.idx2 = MY.m.el.idx2 # input for lav_pml_object_x2glist
# MY.x.el.idx2 = MY.x.el.idx2 # input for lav_pml_object_x2glist
# Npar = Npar
# equalConstr =TRUE

lav_pml_object_inspect_hessian <- function(object, samplestats, X,
                         estimator = "PML", lavcache,
                         MY.m.el.idx, MY.x.el.idx,
                         MY.m.el.idx2, MY.x.el.idx2, # input for lav_pml_object_x2glist
                         Npar, # Npar is the number of parameters under H1
                         equalConstr) { # takes TRUE/ FALSE
  if (equalConstr) { # !!! added line
  }
  Hessian <- matrix(0, Npar, Npar) #

  # !!!! MYfunction below
  x <- lav_pml_object_inspect_parameters(
    object = object,
    GLIST = NULL, N = Npar, # N the number of parameters to consider
    MY.m.el.idx = MY.m.el.idx,
    MY.x.el.idx = MY.x.el.idx
  )

  for (j in 1:Npar) {
    h.j <- 1e-05
    x.left <- x.left2 <- x.right <- x.right2 <- x
    x.left[j] <- x[j] - h.j
    x.left2[j] <- x[j] - 2 * h.j
    x.right[j] <- x[j] + h.j
    x.right2[j] <- x[j] + 2 * h.j
    # !!!! MYfunction below : lav_pml_object_inspect_gradient and  lav_pml_object_x2glist
    g.left <- lav_pml_object_inspect_gradient(
      object = object,
      GLIST = lav_pml_object_x2glist(
        object = object, x = x.left,
        MY.m.el.idx = MY.m.el.idx2,
        MY.x.el.idx = MY.x.el.idx2
      ),
      samplestats = samplestats, X = X,
      lavcache = lavcache, estimator = "PML",
      MY.m.el.idx = MY.m.el.idx,
      MY.x.el.idx = MY.x.el.idx,
      equalConstr = equalConstr
    )

    g.left2 <- lav_pml_object_inspect_gradient(
      object = object,
      GLIST = lav_pml_object_x2glist(
        object = object, x = x.left2,
        MY.m.el.idx = MY.m.el.idx2,
        MY.x.el.idx = MY.x.el.idx2
      ),
      samplestats = samplestats, X = X,
      lavcache = lavcache, estimator = "PML",
      MY.m.el.idx = MY.m.el.idx,
      MY.x.el.idx = MY.x.el.idx,
      equalConstr = equalConstr
    )

    g.right <- lav_pml_object_inspect_gradient(
      object = object,
      GLIST = lav_pml_object_x2glist(
        object = object, x = x.right,
        MY.m.el.idx = MY.m.el.idx2,
        MY.x.el.idx = MY.x.el.idx2
      ),
      samplestats = samplestats, X = X,
      lavcache = lavcache, estimator = "PML",
      MY.m.el.idx = MY.m.el.idx,
      MY.x.el.idx = MY.x.el.idx,
      equalConstr = equalConstr
    )

    g.right2 <- lav_pml_object_inspect_gradient(
      object = object,
      GLIST = lav_pml_object_x2glist(
        object = object, x = x.right2,
        MY.m.el.idx = MY.m.el.idx2,
        MY.x.el.idx = MY.x.el.idx2
      ),
      samplestats = samplestats, X = X,
      lavcache = lavcache, estimator = "PML",
      MY.m.el.idx = MY.m.el.idx,
      MY.x.el.idx = MY.x.el.idx,
      equalConstr = equalConstr
    )

    Hessian[, j] <- (g.left2 - 8 * g.left + 8 * g.right - g.right2) / (12 * h.j)
  }
  Hessian <- (Hessian + t(Hessian)) / 2
  # (-1) * Hessian
  Hessian
}
#############################################################################




##################################  lav_pml_object_inspect_parameters
# different input arguments: MY.m.el.idx, MY.x.el.idx
lav_pml_object_inspect_parameters <- function(object, GLIST = NULL, N, # N the number of parameters to consider
                                 MY.m.el.idx, MY.x.el.idx) {
  if (is.null(GLIST)) {
    GLIST <- object@GLIST
  }

  x <- numeric(N)

  for (mm in 1:length(object@GLIST)) { # mm<-1
    m.idx <- MY.m.el.idx[[mm]] # !!!!! different here and below
    x.idx <- MY.x.el.idx[[mm]]
    x[x.idx] <- GLIST[[mm]][m.idx]
  }
  x
}
#############################################################################




#############################  lav_pml_object_inspect_gradient
# the difference are the input arguments MY.m.el.idx, MY.x.el.idx
# used  in  lavaan:::lav_model_delta
lav_pml_object_inspect_gradient <- function(object, GLIST, samplestats = NULL, X = NULL,
                              lavcache = NULL, estimator = "PML",
                              MY.m.el.idx, MY.x.el.idx, equalConstr) {
  if (equalConstr) { # added line
  }
  num.idx <- object@num.idx
  th.idx <- object@th.idx
  if (is.null(GLIST)) {
    GLIST <- object@GLIST
  }
  Sigma.hat <- lav_model_sigma(object, GLIST = GLIST, extra = (estimator == "ML"))
  Mu.hat <- lav_model_mu(object, GLIST = GLIST)
  TH <- lav_model_th(object, GLIST = GLIST)
  g <- 1
  d1 <- lav_pml_dploglik_dimplied(
    Sigma.hat = Sigma.hat[[g]], Mu.hat = Mu.hat[[g]],
    TH = TH[[g]], th.idx = th.idx[[g]], num.idx = num.idx[[g]],
    X = X[[g]], lavcache = lavcache[[g]]
  )

  # !?  if(equalConstr) { #delete the following three commented lines, wrong
  #     Delta <- lavaan:::lav_model_delta (lavmodel= object, GLIST. = GLIST)
  #  } else {
  Delta <- lav_model_delta(
    lavmodel = object, GLIST. = GLIST,
    m.el.idx. = MY.m.el.idx,
    x.el.idx. = MY.x.el.idx
  )
  # }

  # !!!!! that was before: as.numeric(t(d1) %*% Delta[[g]])/samplestats@nobs[[g]]
  as.numeric(t(d1) %*% Delta[[g]]) # !!! modified to follow current computeGradient() function of lavaan
  # !!! which gives minus the gradient of PL-loglik
}

###############################################################################


##################################  lav_pml_object_x2glist
# difference in input arguments MY.m.el.idx, MY.x.el.idx

lav_pml_object_x2glist <- function(object, x = NULL, MY.m.el.idx, MY.x.el.idx) {
  GLIST <- object@GLIST
  for (mm in 1:length(GLIST)) {
    m.el.idx <- MY.m.el.idx[[mm]]
    x.el.idx <- MY.x.el.idx[[mm]]
    GLIST[[mm]][m.el.idx] <- x[x.el.idx]
  }
  GLIST
}
############################################################################


##### lav_pml_object_information_firstorder function
# difference from corresponding of lavaan: I use lav_pml_model_vcov_firstorder
lav_pml_object_information_firstorder <- function(object, MY.m.el.idx, MY.x.el.idx, equalConstr) {
  NACOV <- lav_pml_model_vcov_firstorder(
    lavmodel = object@Model,
    lavsamplestats = object@SampleStats,
    lavdata = object@Data,
    estimator = "PML",
    MY.m.el.idx = MY.m.el.idx,
    MY.x.el.idx = MY.x.el.idx,
    equalConstr = equalConstr
  )
  if (equalConstr) { # added lines
  }
  B0 <- attr(NACOV, "B0")
  # !!!! Note below that I don't multiply  with nsize
  # !!! so what I get is J matrix divided by n
  # if (object@Options$estimator == "PML") {
  #    B0 <- B0 * object@SampleStats@ntotal
  # }
  # !!!!!!!!!!!!!!!!!!! added the following lines so that the output of
  # !!!!! lav_pml_object_information_firstorder is in line with that of lavaan 0.5-18 getVariability
  # !! what's the purpose of the following lines?
  if (object@Options$estimator == "PML") {
    B0 <- B0 * object@SampleStats@ntotal
  }

  B0
}

##############################################################################
# example
# obj <- fit.objH0[[i]]
# object <- obj@Model
# samplestats = obj@SampleStats
# X = obj@Data@X
# estimator = "PML"
# lavcache = obj@Cache
# MY.m.el.idx = MY.m.el.idx
# MY.x.el.idx = MY.x.el.idx
# MY.m.el.idx2 = MY.m.el.idx2 # input for lav_pml_object_x2glist
# MY.x.el.idx2 = MY.x.el.idx2 # input for lav_pml_object_x2glist
# Npar = Npar
# equalConstr =TRUE


lav_pml_model_vcov_firstorder <- function(lavmodel, lavsamplestats = NULL,
                                lavdata = NULL, lavcache = NULL,
                                estimator = "PML",
                                MY.m.el.idx, MY.x.el.idx,
                                equalConstr) { # equalConstr takes TRUE/FALSE
  if (equalConstr) { # added lines
  }
  B0.group <- vector("list", lavsamplestats@ngroups) # in my case list of length 1

  # !?   if (equalConstr) {     ###the following three lines are commented because they are wrong
  #      Delta <- lavaan:::lav_model_delta(lavmodel, GLIST. = NULL)
  #   } else {
  Delta <- lav_model_delta(lavmodel,
    GLIST. = NULL,
    m.el.idx. = MY.m.el.idx, # !!!!! different here and below
    x.el.idx. = MY.x.el.idx
  )
  #  }
  Sigma.hat <- lav_model_sigma(lavmodel)
  Mu.hat <- lav_model_mu(lavmodel)
  TH <- lav_model_th(lavmodel)
  g <- 1

  SC <- lav_pml_dploglik_dimplied(
    Sigma.hat = Sigma.hat[[g]], TH = TH[[g]],
    Mu.hat = Mu.hat[[g]], th.idx = lavmodel@th.idx[[g]],
    num.idx = lavmodel@num.idx[[g]],
    X = lavdata@X[[g]], lavcache = lavcache,
    scores = TRUE, negative = FALSE
  )
  group.SC <- SC %*% Delta[[g]]
  B0.group[[g]] <- lav_matrix_crossprod(group.SC)
  # !!!! B0.group[[g]] <- B0.group[[g]]/lavsamplestats@ntotal  !!! skip so that the result
  # is in line with the 0.5-18 version of lavaan

  B0 <- B0.group[[1]]

  E <- B0

  eigvals <- eigen(E, symmetric = TRUE, only.values = TRUE)$values
  if (any(eigvals < -1 * .Machine$double.eps^(3 / 4))) {
    lav_msg_warn(gettext(
      "matrix based on first order outer product of the derivatives is not
      positive definite; the standard errors may not be thrustworthy"))
  }
  NVarCov <- MASS::ginv(E)

  attr(NVarCov, "B0") <- B0
  attr(NVarCov, "B0.group") <- B0.group
  NVarCov
}

# functions related to the SRMR fit measures (single level only)

# lower-level functions:
# - lav_fit_srmr_mplus
# - lav_fit_srmr_twolevel

# higher-level functions:
# - lav_fit_srmr_lavobject

# Y.R. 22 July 2022

# Note: for rmrm/srmr/crmr, we use lav_residuals_summmary()

# SRMR for continuous data only
# see https://www.statmodel.com/download/SRMR.pdf
lav_fit_srmr_mplus <- function(lavobject) {

  lavsamplestats <- lavobject@SampleStats
  lavh1 <- lavobject@h1

  # ngroups
  G <- lavobject@Data@ngroups

  # container per group
  srmr_mplus.group <- numeric(G)
  srmr_mplus_nomean.group <- numeric(G)

  # If you change how any of the observed/estimated moments below are retrieved,
  # please tag @TDJorgensen at the end of the commit message.
  for (g in 1:G) {
    # observed
    if (!lavsamplestats@missing.flag) {
      if (lavobject@Model@conditional.x) {
        S <- lavsamplestats@res.cov[[g]]
        M <- lavsamplestats@res.int[[g]]
      } else {
        S <- lavsamplestats@cov[[g]]
        M <- lavsamplestats@mean[[g]]
      }
    } else {
      # EM estimates
      if (!is.null(lavh1$implied$cov[[g]])) {
        S <- lavh1$implied$cov[[g]]
      } else {
        S <- lavsamplestats@missing.h1[[g]]$sigma
      }
      if (!is.null(lavh1$implied$mean[[g]])) {
        M <- lavh1$implied$mean[[g]]
      } else {
        M <- lavsamplestats@missing.h1[[g]]$mu
      }
    }
    nvar <- ncol(S)

    # estimated
    implied <- lavobject@implied
    lavmodel <- lavobject@Model
    Sigma.hat <- if (lavmodel@conditional.x) {
      implied$res.cov[[g]]
    } else {
      implied$cov[[g]]
    }
    Mu.hat <- if (lavmodel@conditional.x) {
      implied$res.int[[g]]
    } else {
      implied$mean[[g]]
    }

    # Bollen approach: simply using cov2cor ('correlation residuals')
    S.cor <- cov2cor(S)
    Sigma.cor <- cov2cor(Sigma.hat)
    R.cor <- (S.cor - Sigma.cor)

    # meanstructure
    if (lavobject@Model@meanstructure) {
      # standardized residual mean vector
      R.cor.mean <- M / sqrt(diag(S)) - Mu.hat / sqrt(diag(Sigma.hat))

      e <- nvar * (nvar + 1) / 2 + nvar
      srmr_mplus.group[g] <-
        sqrt((sum(R.cor[lower.tri(R.cor, diag = FALSE)]^2) +
          sum(R.cor.mean^2) +
          sum(((diag(S) - diag(Sigma.hat)) / diag(S))^2)) / e)

      e <- nvar * (nvar + 1) / 2
      srmr_mplus_nomean.group[g] <-
        sqrt((sum(R.cor[lower.tri(R.cor, diag = FALSE)]^2) +
          sum(((diag(S) - diag(Sigma.hat)) / diag(S))^2)) / e)
    } else {
      e <- nvar * (nvar + 1) / 2
      srmr_mplus_nomean.group[g] <- srmr_mplus.group[g] <-
        sqrt((sum(R.cor[lower.tri(R.cor, diag = FALSE)]^2) +
          sum(((diag(S) - diag(Sigma.hat)) / diag(S))^2)) / e)
    }
  } # G

  attr(srmr_mplus.group, "nomean") <- srmr_mplus_nomean.group
  srmr_mplus.group
}

lav_fit_srmr_twolevel <- function(lavobject = NULL) {
  nlevels <- lavobject@Data@nlevels
  G <- lavobject@Data@ngroups

  SRMR.within <- numeric(G)
  SRMR.between <- numeric(G)
  for (g in 1:G) {
    b.within <- (g - 1L) * nlevels + 1L
    b.between <- (g - 1L) * nlevels + 2L

    # OBSERVED        # if these change, tag @TDJorgensen in commit message
    S.within <- lavobject@h1$implied$cov[[b.within]]
    M.within <- lavobject@h1$implied$mean[[b.within]]
    S.between <- lavobject@h1$implied$cov[[b.between]]
    M.between <- lavobject@h1$implied$mean[[b.between]]

    # ESTIMATED       # if these change, tag @TDJorgensen in commit message
    implied <- lav_model_implied_cond2uncond(lavobject@implied)
    Sigma.within <- implied$cov[[b.within]]
    Mu.within <- implied$mean[[b.within]]
    Sigma.between <- implied$cov[[b.between]]
    Mu.between <- implied$mean[[b.between]]

    # force pd for between
    #    S.between <- lav_matrix_symmetric_force_pd(S.between)
    Sigma.between <- lav_matrix_symmetric_force_pd(Sigma.between)

    # Bollen approach: simply using cov2cor ('residual correlations')
    S.within.cor <- cov2cor(S.within)
    S.between.cor <- cov2cor(S.between)
    Sigma.within.cor <- cov2cor(Sigma.within)
    if (all(diag(Sigma.between) > 0)) {
      Sigma.between.cor <- cov2cor(Sigma.between)
    } else {
      Sigma.between.cor <- matrix(as.numeric(NA),
        nrow = nrow(Sigma.between),
        ncol = ncol(Sigma.between)
      )
    }
    R.within.cor <- (S.within.cor - Sigma.within.cor)
    R.between.cor <- (S.between.cor - Sigma.between.cor)

    nvar.within <- NCOL(S.within)
    nvar.between <- NCOL(S.between)
    pstar.within <- nvar.within * (nvar.within + 1) / 2
    pstar.between <- nvar.between * (nvar.between + 1) / 2

    # SRMR
    SRMR.within[g] <- sqrt(sum(lav_matrix_vech(R.within.cor)^2) /
      pstar.within)
    SRMR.between[g] <- sqrt(sum(lav_matrix_vech(R.between.cor)^2) /
      pstar.between)
  }

  # adjust for group sizes
  ng <- unlist(lavobject@SampleStats@nobs)  # if this changes, tag @TDJorgensen in commit message
  ntotal <- lavobject@SampleStats@ntotal    # if this changes, tag @TDJorgensen in commit message
  SRMR_WITHIN <- sum(ng / ntotal * SRMR.within)
  SRMR_BETWEEN <- sum(ng / ntotal * SRMR.between)
  SRMR_TOTAL <- SRMR_WITHIN + SRMR_BETWEEN

  c(SRMR_TOTAL, SRMR_WITHIN, SRMR_BETWEEN)
}

lav_fit_srmr_lavobject <- function(lavobject = NULL, fit.measures = "rmsea") {
  # check lavobject
  stopifnot(inherits(lavobject, "lavaan"))

  # categorical?
  categorical <- lavobject@Model@categorical

  # supported fit measures in this function
  if (categorical) {
    fit.srmr <- c("srmr")
    fit.srmr2 <- c(
      "rmr", "rmr_nomean",
      "srmr", # per default equal to srmr_bentler_nomean
      "srmr_bentler", "srmr_bentler_nomean",
      "crmr", "crmr_nomean",
      "srmr_mplus", "srmr_mplus_nomean"
    )
  } else {
    if (lavobject@Data@nlevels > 1L) {
      fit.srmr <- c("srmr", "srmr_within", "srmr_between")
      fit.srmr2 <- c("srmr", "srmr_within", "srmr_between")
    } else {
      fit.srmr <- c("srmr")
      fit.srmr2 <- c(
        "rmr", "rmr_nomean",
        "srmr", # the default
        "srmr_bentler", "srmr_bentler_nomean",
        "crmr", "crmr_nomean",
        "srmr_mplus", "srmr_mplus_nomean"
      )
    }
  }

  # which one do we need?
  if (missing(fit.measures)) {
    # default set
    fit.measures <- fit.srmr
  } else {
    # remove any not-SRMR related index from fit.measures
    rm.idx <- which(!fit.measures %in% fit.srmr2)
    if (length(rm.idx) > 0L) {
      fit.measures <- fit.measures[-rm.idx]
    }
    if (length(fit.measures) == 0L) {
      return(list())
    }
  }

  # output container
  indices <- list()

  # 1. single level
  if (lavobject@Data@nlevels == 1L) {
    # RMR/SRMR/CRMR: we get it from lav_residuals_summary()
    out <- lav_residuals_summary(lavobject, se = FALSE, unbiased = FALSE)

    cov.cor <- "cov"
    if (categorical) {
      cov.cor <- "cor"
    }

    # only cov
    rmr_nomean.group <- sapply(lapply(out, "[[", "rmr"), "[[", cov.cor)
    srmr_nomean.group <- sapply(lapply(out, "[[", "srmr"), "[[", cov.cor)
    crmr_nomean.group <- sapply(lapply(out, "[[", "crmr"), "[[", cov.cor)

    # total
    if (lavobject@Model@meanstructure) {
      rmr.group <- sapply(lapply(out, "[[", "rmr"), "[[", "total")
      srmr.group <- sapply(lapply(out, "[[", "srmr"), "[[", "total")
      crmr.group <- sapply(lapply(out, "[[", "crmr"), "[[", "total")
    } else {
      # no 'total', only 'cov'
      rmr.group <- rmr_nomean.group
      srmr.group <- srmr_nomean.group
      crmr.group <- crmr_nomean.group
    }

    # the Mplus versions
    srmr_mplus.group <- lav_fit_srmr_mplus(lavobject = lavobject)
    srmr_mplus_nomean.group <- attr(srmr_mplus.group, "nomean")
    attr(srmr_mplus.group, "nomean") <- NULL

    # adjust for group sizes
    ng <- unlist(lavobject@SampleStats@nobs)  # if this changes, tag @TDJorgensen in commit message
    ntotal <- lavobject@SampleStats@ntotal    # if this changes, tag @TDJorgensen in commit message
    RMR <- sum(ng / ntotal * rmr.group)
    RMR_NOMEAN <- sum(ng / ntotal * rmr_nomean.group)
    SRMR_BENTLER <- sum(ng / ntotal * srmr.group)
    SRMR_BENTLER_NOMEAN <- sum(ng / ntotal * srmr_nomean.group)
    CRMR <- sum(ng / ntotal * crmr.group)
    CRMR_NOMEAN <- sum(ng / ntotal * crmr_nomean.group)
    SRMR_MPLUS <- sum(ng / ntotal * srmr_mplus.group)
    SRMR_MPLUS_NOMEAN <- sum(ng / ntotal * srmr_mplus_nomean.group)

    # srmr
    if (lavobject@Options$mimic %in% c("lavaan", "EQS")) {
      if (categorical) {
        indices["srmr"] <- SRMR_BENTLER_NOMEAN
      } else {
        indices["srmr"] <- SRMR_BENTLER
      }
    } else if (lavobject@Options$mimic == "Mplus") {
      if (lavobject@Options$information[1] == "expected") {
        if (categorical) {
          indices["srmr"] <- SRMR_BENTLER_NOMEAN
        } else {
          indices["srmr"] <- SRMR_BENTLER
        }
      } else {
        if (categorical) {
          indices["srmr"] <- SRMR_MPLUS_NOMEAN
        } else {
          indices["srmr"] <- SRMR_MPLUS
        }
      }
    } # Mplus only

    # the others
    indices["srmr_bentler"] <- SRMR_BENTLER
    indices["srmr_bentler_nomean"] <- SRMR_BENTLER_NOMEAN
    indices["crmr"] <- CRMR
    indices["crmr_nomean"] <- CRMR_NOMEAN

    # only correct for non-categorical:
    if (lavobject@Model@categorical) {
      # FIXME! Compute Mplus 8.1 way to compute SRMR in the
      #        categorical setting
      #        See 'SRMR in Mplus (2018)' document on Mplus website
      indices["srmr_mplus"] <- as.numeric(NA)
      indices["srmr_mplus_nomean"] <- as.numeric(NA)
    } else {
      indices["srmr_mplus"] <- SRMR_MPLUS
      indices["srmr_mplus_nomean"] <- SRMR_MPLUS_NOMEAN
    }
    indices["rmr"] <- RMR
    indices["rmr_nomean"] <- RMR_NOMEAN
  } else {
    # 2. twolevel setting
    out <- lav_fit_srmr_twolevel(lavobject = lavobject)
    indices["srmr"] <- out[1]
    indices["srmr_within"] <- out[2]
    indices["srmr_between"] <- out[3]
  } # twolevel

  # return only those that were requested
  indices[fit.measures]
}

# merge two parameter tables
# - but allow different number of columns
lav_partable_merge <- function(pt1 = NULL, pt2 = NULL,
                               remove.duplicated = FALSE,
                               fromLast = FALSE,
                               warn = TRUE) {
  if (!missing(warn)) {
    current.warn <- lav_warn()
    if (lav_warn(warn))
      on.exit(lav_warn(current.warn), TRUE)
  }
  # check for empty pt2
  if (is.null(pt2) || length(pt2) == 0L) {
    return(pt1)
  }

  pt1 <- as.data.frame(pt1, stringsAsFactors = FALSE)
  pt2 <- as.data.frame(pt2, stringsAsFactors = FALSE)

  # check minimum requirements: lhs, op, rhs
  stopifnot(
    !is.null(pt1$lhs), !is.null(pt1$op), !is.null(pt1$rhs),
    !is.null(pt2$lhs), !is.null(pt2$op), !is.null(pt2$rhs)
  )

  # both should have block (or not)
  if (is.null(pt1$block) && is.null(pt2$block)) {
    pt1$block <- rep(1L, length(pt1$lhs))
    pt2$block <- rep(1L, length(pt2$lhs))
    TMP <- rbind(
      pt1[, c("lhs", "op", "rhs", "block")],
      pt2[, c("lhs", "op", "rhs", "block")]
    )
  } else {
    if (is.null(pt1$block) && !is.null(pt2$block)) {
      pt1$block <- rep(1L, length(pt1$lhs))
    } else if (is.null(pt2$block) && !is.null(pt1$block)) {
      pt2$block <- rep(1L, length(pt2$lhs))
    }
    TMP <- rbind(
      pt1[, c("lhs", "op", "rhs", "block")],
      pt2[, c("lhs", "op", "rhs", "block")]
    )
  }

  # if missing columns, provide default values of the right type
  # (numeric/integer/character)

  # group
  if (is.null(pt1$group) && !is.null(pt2$group)) {
    pt1$group <- rep(1L, length(pt1$lhs))
  } else if (is.null(pt2$group) && !is.null(pt1$group)) {
    pt2$group <- rep(1L, length(pt2$lhs))
  }

  # level
  if (is.null(pt1$level) && !is.null(pt2$level)) {
    pt1$level <- rep(1L, length(pt1$lhs))
  } else if (is.null(pt2$level) && !is.null(pt1$level)) {
    pt2$level <- rep(1L, length(pt2$lhs))
  }

  # user
  if (is.null(pt1$user) && !is.null(pt2$user)) {
    pt1$user <- rep(0L, length(pt1$lhs))
  } else if (is.null(pt2$user) && !is.null(pt1$user)) {
    pt2$user <- rep(0L, length(pt2$lhs))
  }

  # free
  if (is.null(pt1$free) && !is.null(pt2$free)) {
    pt1$free <- rep(0L, length(pt1$lhs))
  } else if (is.null(pt2$free) && !is.null(pt1$free)) {
    pt2$free <- rep(0L, length(pt2$lhs))
  }

  # ustart -- set to zero!!
  if (is.null(pt1$ustart) && !is.null(pt2$ustart)) {
    pt1$ustart <- rep(0, length(pt1$lhs))
  } else if (is.null(pt2$ustart) && !is.null(pt1$ustart)) {
    pt2$ustart <- rep(0, length(pt2$lhs))
  }

  # exo
  if (is.null(pt1$exo) && !is.null(pt2$exo)) {
    pt1$exo <- rep(0L, length(pt1$lhs))
  } else if (is.null(pt2$exo) && !is.null(pt1$exo)) {
    pt2$exo <- rep(0L, length(pt2$lhs))
  }

  # label
  if (is.null(pt1$label) && !is.null(pt2$label)) {
    pt1$label <- rep("", length(pt1$lhs))
  } else if (is.null(pt2$label) && !is.null(pt1$label)) {
    pt2$label <- rep("", length(pt2$lhs))
  }

  # plabel
  if (is.null(pt1$plabel) && !is.null(pt2$plabel)) {
    pt1$plabel <- rep("", length(pt1$lhs))
  } else if (is.null(pt2$plabel) && !is.null(pt1$plabel)) {
    pt2$plabel <- rep("", length(pt2$lhs))
  }

  # efa
  if (is.null(pt1$efa) && !is.null(pt2$efa)) {
    pt1$efa <- rep("", length(pt1$lhs))
  } else if (is.null(pt2$efa) && !is.null(pt1$efa)) {
    pt2$efa <- rep("", length(pt2$lhs))
  }

  # start
  if (is.null(pt1$start) && !is.null(pt2$start)) {
    pt1$start <- rep(as.numeric(NA), length(pt1$lhs))
  } else if (is.null(pt2$start) && !is.null(pt1$start)) {
    pt2$start <- rep(as.numeric(NA), length(pt2$lhs))
  }

  # est
  if (is.null(pt1$est) && !is.null(pt2$est)) {
    pt1$est <- rep(0, length(pt1$lhs))
  } else if (is.null(pt2$est) && !is.null(pt1$est)) {
    pt2$est <- rep(0, length(pt2$lhs))
  }


  # check for duplicated elements
  if (remove.duplicated) {
    # if fromLast = TRUE, idx is in pt1
    # if fromLast = FALSE, idx is in pt2
    idx <- which(duplicated(TMP, fromLast = fromLast))

    if (length(idx)) {
      lav_msg_warn(
        gettext("duplicated parameters are ignored:"),
        paste(apply(TMP[idx, c("lhs", "op", "rhs")], 1,
          paste,
          collapse = " "
        ), collapse = "\n")
      )
      if (fromLast) {
        pt1 <- pt1[-idx, ]
      } else {
        idx <- idx - nrow(pt1)
        pt2 <- pt2[-idx, ]
      }
    }
  } else if (!is.null(pt1$start) && !is.null(pt2$start)) {
    # copy start values from pt1 to pt2
    for (i in 1:length(pt1$lhs)) {
      idx <- which(pt2$lhs == pt1$lhs[i] &
        pt2$op == pt1$op[i] &
        pt2$rhs == pt1$rhs[i] &
        pt2$block == pt1$block[i])

      pt2$start[idx] <- pt1$start[i]
    }
  }

  # nicely merge, using 'id' column (if it comes first)
  if (is.null(pt1$id) && !is.null(pt2$id)) {
    nid <- max(pt2$id)
    pt1$id <- (nid + 1L):(nid + nrow(pt1))
  } else if (is.null(pt2$id) && !is.null(pt1$id)) {
    nid <- max(pt1$id)
    pt2$id <- (nid + 1L):(nid + nrow(pt2))
  }

  NEW <- base::merge(pt1, pt2, all = TRUE, sort = FALSE)

  # make sure group/block/level are zero (or "") if
  # op %in% c("==", "<", ">", ":=")
  op.idx <- which(NEW$op %in% c("==", "<", ">", ":="))
  if (length(op.idx) > 0L) {
    if (!is.null(NEW$block)) {
      # ALWAYS integer
      NEW$block[op.idx] <- 0L
    }
    if (!is.null(NEW$group)) {
      if (is.character(NEW$level)) {
        NEW$group[op.idx] <- ""
      } else {
        NEW$group[op.idx] <- 0L
      }
    }
    if (!is.null(NEW$level)) {
      if (is.character(NEW$level)) {
        NEW$level[op.idx] <- ""
      } else {
        NEW$level[op.idx] <- 0L
      }
    }
  }

  NEW
}

# return 'attributes' of a lavaan partable -- generate a new set if necessary
lav_partable_attributes <- function(partable, pta = NULL) {
  if (is.null(pta)) {
    # attached to partable?
    pta <- attributes(partable)
    if (!is.null(pta$vnames) && !is.null(pta$nvar)) {
      # looks like a pta
      pta$ovda <- NULL
      return(pta)
    } else {
      pta <- list()
    }
  }

  # vnames
  pta$vnames <- lav_partable_vnames(partable, type = "*")

  # vidx
  tmp.ov <- pta$vnames$ov
  tmp.lv <- pta$vnames$lv
  nblocks <- length(pta$vnames$ov)
  pta$vidx <- lapply(names(pta$vnames), function(v) {
    lapply(seq_len(nblocks), function(b) {
      if (v == "lv.marker") {
        match(pta$vnames[[v]][[b]], tmp.ov[[b]])
      } else if (grepl("lv", v)) {
        match(pta$vnames[[v]][[b]], tmp.lv[[b]])
      } else if (grepl("th", v)) {
        # thresholds have '|t' pattern
        tmp.th <- sapply(strsplit(pta$vnames[[v]][[b]],
          "|t",
          fixed = TRUE
        ), "[[", 1L)
        match(tmp.th, tmp.ov[[b]])
      } else if (grepl("eqs", v)) {
        # mixture of tmp.ov/tmp.lv
        integer(0L)
      } else {
        match(pta$vnames[[v]][[b]], tmp.ov[[b]])
      }
    })
  })
  names(pta$vidx) <- names(pta$vnames)

  # meanstructure
  pta$meanstructure <- any(partable$op == "~1")

  # nblocks
  pta$nblocks <- nblocks

  # ngroups
  pta$ngroups <- lav_partable_ngroups(partable)

  # nlevels
  pta$nlevels <- lav_partable_nlevels(partable)

  # nvar
  pta$nvar <- lapply(pta$vnames$ov, length)

  # nfac
  pta$nfac <- lapply(pta$vnames$lv, length)

  # nfac.nonnormal - for numerical integration
  pta$nfac.nonnormal <- lapply(pta$vnames$lv.nonnormal, length)

  # th.idx (new in 0.6-1)
  pta$th.idx <- lapply(seq_len(pta$nblocks), function(b) {
    out <- numeric(length(pta$vnames$th.mean[[b]]))
    idx <- (pta$vnames$th.mean[[b]] %in%
      pta$vnames$th[[b]])
    out[idx] <- pta$vidx$th[[b]]
    out
  })

  pta
}

lav_plotinfo_svgcode <- function(plotinfo,
                         outfile = "",
                         sloped.labels = TRUE,
                         standalone = FALSE,
                         stroke.width = 2L,
                         font.size = 20L,
                         idx.font.size = 15L,
                         dy = 5L,
                         mlovcolors = c("lightgreen", "lightblue"),
                         lightness = 1,
                         font.family = "Latin Modern Math, arial, Aerial, sans",
                         italic = TRUE,
                         auto.subscript = TRUE
                         ) {
  textattr <- paste0('fill="black" font-size="', font.size,
              '" font-family="', font.family, '" ',
              ifelse(italic, 'font-style="italic"',''))
  tmpcol <- col2rgb(mlovcolors)
  wovcol <- paste(as.hexmode(tmpcol[, 1L]), collapse = "")
  bovcol <- paste(as.hexmode(tmpcol[, 2L]), collapse = "")
  node_elements_svg <- function(nodetiepe, noderadius, waar, stroke.width) {
    # define form, color and anchors for a node
    localradius <- noderadius
    if (nodetiepe == "varlv") localradius <- noderadius * .8
    ovxy <- localradius * sqrt(0.5)
    cvxy <- localradius * c(0.5, sqrt(0.75))
    constxy <- cvxy
    drawit <- switch(nodetiepe,
                     lv = ,
                     varlv = paste0('<circle cx="', waar[1], '" cy="', waar[2],
                                    '" r="', localradius,
                                    '" stroke-width="', stroke.width,
                                    '" stroke="black" fill="white"/>'),
                     ov = paste0('<rect width="', 2 * ovxy, '" height="',
                                 2 * ovxy, '" x="', waar[1] - ovxy, '" y="',
                                 waar[2] - ovxy,
                                 '" stroke-width="', stroke.width,
                                 '" stroke="black" fill="white" />'),
                     wov =  paste0('<rect width="', 2 * ovxy, '" height="',
                                   2 * ovxy, '" x="', waar[1] - ovxy, '" y="',
                                   waar[2] - ovxy, '" rx="', ovxy / 3, '" ry="',
                                   ovxy / 3, '" stroke-width="', stroke.width,
                                   '" stroke="black" fill="#', wovcol,
                                   '" />'),
                     bov =  paste0('<rect width="', 2 * ovxy, '" height="',
                                   2 * ovxy, '" x="', waar[1] - ovxy, '" y="',
                                   waar[2] - ovxy, '" rx="', ovxy / 3, '" ry="',
                                   ovxy / 3, '" stroke-width="', stroke.width,
                                   '" stroke="black" fill="#', bovcol,
                                   '" />'),
                     cv = paste0('<polygon points="',
                                 waar[1] - cvxy[1], ',', waar[2] - cvxy[2], ' ',
                                 waar[1] + cvxy[1], ',', waar[2] - cvxy[2], ' ',
                                 waar[1] + localradius, ',', waar[2], ' ',
                                 waar[1] + cvxy[1], ',', waar[2] + cvxy[2], ' ',
                                 waar[1] - cvxy[1], ',', waar[2] + cvxy[2], ' ',
                                 waar[1] - localradius, ',', waar[2],
                                 '" stroke-width="', stroke.width,
                                 '" stroke="black" fill="none" />'),
                     const = paste0('<polygon points="',
                                    waar[1], ',', waar[2] - localradius, ' ',
                                    waar[1] + constxy[2], ',', waar[2] + constxy[1], ' ',
                                    waar[1] - constxy[2], ',', waar[2] + constxy[1],
                                    '" stroke-width="', stroke.width,
                                    '" stroke="black" fill="none" />')
    )
    n <- c(waar[1], switch(nodetiepe,
                           lv = , varlv = , const = waar[2] - localradius,
                           ov = , wov = , bov = waar[2] - ovxy,
                           cv = waar[2] - cvxy[2]))
    s <- c(waar[1], switch(nodetiepe,
                           lv = , varlv = waar[2] + localradius,
                           ov = , wov = , bov = waar[2] + ovxy,
                           cv = waar[2]  + cvxy[2],
                           const = waar[2] + constxy[1]))
    e <- switch(nodetiepe,
                lv = , varlv = , cv = waar + c(localradius, 0),
                ov = , wov = , bov = waar + c(ovxy, 0),
                const = waar + c(constxy[2], constxy[1]))
    w <- switch(nodetiepe,
                lv = , varlv = , cv = waar + c(-localradius, 0),
                ov = , wov = , bov = waar + c(-ovxy, 0),
                const = waar + c(-constxy[2], constxy[1]))
    ne <- switch(nodetiepe,
                 lv = , varlv = , ov = , wov = ,
                 bov = waar + ovxy * c(1, -1),
                 cv = waar + c(cvxy[1], -cvxy[2]),
                 const = e)
    nw <- switch(nodetiepe,
                 lv = , varlv = , ov = , wov = ,
                 bov = waar + ovxy * c(-1, -1),
                 cv = waar + c(-cvxy[1], -cvxy[2]),
                 const = w)
    se <- switch(nodetiepe,
                 lv = , varlv = , ov = , wov = ,
                 bov = waar + ovxy * c(1, 1),
                 cv = waar + cvxy,
                 const = e)
    sw <- switch(nodetiepe,
                 lv = , varlv = , ov = , wov = ,
                 bov = waar + ovxy * c(-1, 1),
                 cv = waar + c(-cvxy[1L], cvxy[2L]),
                 const = w)
    list(drawit = drawit, n = n, ne = ne, e = e,
         se = se, s = s, sw = sw, w = w, nw = nw)
  }
  get_file_extension <- function(path) {
    if (path == "") return("")
    delen <- strsplit(path, ".", fixed = TRUE)[[1]]
    if (length(delen) > 1L) return(tolower(delen[length(delen)]))
    return("")
  }
  if (is.character(outfile) && outfile != "") {
    stopifnot(standalone || get_file_extension(outfile) == "svg",
              !standalone || get_file_extension(outfile) %in% c("htm", "html"))
  }
  mlrij <- plotinfo$mlrij
  if (is.null(mlrij))
    lav_msg_stop(gettext(
      "plotinfo hasn't been processed by lav_plotinfo_positions!"))
  if (outfile == "") outfile <- stdout()
  if (is.character(outfile)) {
    zz <- file(outfile, open = "w")
    closezz <- TRUE
  } else {
    zz <- outfile
    closezz <- FALSE
  }
  nodes <- plotinfo$nodes
  edges <- plotinfo$edges
  nodedist <- 100
  noderadius <- 0.3
  rijen <- max(nodes$rij)
  kolommen <- max(nodes$kolom)
  nodes$rij <- nodes$rij + 1
  nodes$kolom <- nodes$kolom + 1
  if (lightness != 1) {
    mlrij <- lightness * mlrij
    nodes$kolom <- lightness * nodes$kolom
    nodes$rij <- lightness * nodes$rij
    edges$controlpt.kol <- lightness * edges$controlpt.kol
    edges$controlpt.rij <- lightness * edges$controlpt.rij
  }
  if (standalone) {
    writeLines(c(
      '<!DOCTYPE html>',
      '<html>',
      '<body>',
      '<h2>SVG diagram created by lav_plot R package</h2>'),
      zz)
  }
  writeLines(c(
    paste0('<svg width="', lightness * (kolommen + 3) * nodedist, '" height="',
           lightness * (rijen + 3) * nodedist,
           '" version="1.1" xmlns="http://www.w3.org/2000/svg"',
           ' xmlns:xlink="http://www.w3.org/1999/xlink">'),
    '<rect width="100%" height="100%" fill="white" />',
    '<defs>',
    '  <marker id="arr" markerWidth="6" markerHeight="6"',
    '          refX="6" refY="2.5" orient="auto">',
    '    <path d="M 0 0 L 6 2.5 L 0 5 L 2 2.5 z" fill="black" />',
    '  </marker>',
    '  <marker id="sarr" markerWidth="6" markerHeight="6"',
    '          refX="0" refY="2.5" orient="auto">',
    '    <path d="M 0 2.5 L 6 0 L 4 2.5 L 6 5 z" fill="black" />',
    '  </marker>',
    '</defs>'),
     zz)
  plot_edge <- function(van, naar, label = "", dubbel = FALSE,
                        control = NA_real_, below = FALSE,
                        id = 0) {
    labele <- lav_label_code(label,
                               idx.font.size = idx.font.size,
                               dy = dy,
                               auto.subscript = auto.subscript)$svg
    dirvec <- naar - van
    theta <- atan2(naar[2] - van[2], naar[1] - van[1])
    if (is.na(control[1L])) { # line
      if (van[1L] <= naar[1L]) {
        writeLines(paste0('<path id="L', id, '" d="M ', van[1L],
                          ' ', van[2L], ' L ', naar[1L], " ", naar[2L],
                        '" stroke-width="', stroke.width, '" stroke="black" ',
                        ifelse(dubbel,'marker-start="url(#sarr)" ', ''),
                        'marker-end="url(#arr)" />'), zz)
      } else {
        writeLines(paste0('<path d="M ', van[1L],
                          ' ', van[2L], ' L ', naar[1L], " ", naar[2L],
                          '" stroke-width="', stroke.width, '" stroke="black" ',
                          ifelse(dubbel,'marker-start="url(#sarr)" ', ''),
                          'marker-end="url(#arr)" />'), zz)
        writeLines(paste0('<path id="L', id, '" d="M ', naar[1L],
                          ' ', naar[2L], ' L ', van[1L], " ", van[2L],
                          '" stroke-width="0" stroke="none" fill="none" />'),
                   zz)
      }
      midden <- (van + naar) * 0.5
    } else {  # path Q (quadratic B\'{e}zier)
      if (van[1L] <= naar[1L]) {
        writeLines(paste0('<path id="L', id, '" d="M ', van[1L], ' ',
                          van[2L], ' Q ', control[1L], ' ', control[2L],
                          ' ', naar[1L], " ", naar[2L],
                          '" stroke-width="', stroke.width, '" stroke="black" fill="none" ',
                          ifelse(dubbel,'marker-start="url(#sarr)" ', ''),
                          'marker-end="url(#arr)" />'), zz)
      } else {
        writeLines(paste0('<path d="M ', van[1L], ' ',
                          van[2L], ' Q ', control[1L], ' ', control[2L],
                          ' ', naar[1L], " ", naar[2L],
                          '" stroke-width="', stroke.width, '" stroke="black" fill="none" ',
                          ifelse(dubbel,'marker-start="url(#sarr)" ', ''),
                          'marker-end="url(#arr)" />'), zz)
        writeLines(paste0('<path id="L', id, '" d="M ', naar[1L], ' ',
                          naar[2L], ' Q ', control[1L], ' ', control[2L],
                          ' ', van[1L], " ", van[2L],
                          '" stroke-width="0" stroke="none" fill="none" />'),
                   zz)
      }
      midden <- 0.25 * (van + naar) + 0.5 * control
    }
    if (label != "") {
      if (sloped.labels) {
        writeLines(
          c(paste0('<text ', textattr, ' text-anchor="middle">'),
            paste0('<textPath xlink:href="#L', id, '" startOffset="50%">',
                   labele, '</textPath>'),
            '</text>'), zz)
      } else {
        if (below) {
        if (theta >= 0 && theta < pi / 2) {
          extra <- 'dy="30"'
        } else if (theta >= pi / 2) {
          extra <- 'dy="30" text-anchor="end"'
        } else if (theta < -pi/2) {
          extra <- 'dy="30"'
        } else {
          extra <- 'dy="0" text-anchor="end"'
        }
      } else {
        if (theta >= 0 && theta < pi / 2) {
          extra <- 'text-anchor="end"'
        } else if (theta >= pi / 2) {
          extra <- ' '
        } else if (theta < -pi/2) {
          extra <- 'text-anchor="end"'
        } else {
          extra <- ' '
        }
        writeLines(paste0('<text x="', midden[1L], '" y="', midden[2L],
                          '" ', textattr, ' ', extra, '>', labele, '</text>'),
                   zz)
        }
      }
    }
  }
  plot_var <- function(waar, noderadius, label = "", side = "n") {
    labele <- lav_label_code(label,
                               idx.font.size = idx.font.size,
                               dy = dy,
                               auto.subscript = auto.subscript)$svg
    thetarange <- c(pi / 6, 11 * pi / 6)
    if (side == "s") thetarange <- thetarange + 3 * pi / 2
    if (side == "e") thetarange <- thetarange + pi
    if (side == "n") thetarange <- thetarange + pi / 2
    localradius <- noderadius * 0.8
    middelpt <- switch(side,
                       n = c(0, -localradius),
                       w = c(-localradius, 0),
                       s = c(0, localradius),
                       e = c(localradius, 0))
    middelpt <- middelpt + waar
    # cirkelsegment
    straal <- localradius
    xs <- middelpt[1] + cos(thetarange) * straal
    ys <- middelpt[2] + sin(thetarange) * straal
    writeLines(paste0(
      '<path d="M ', xs[1L], ' ', ys[1L], ' A ', straal, ' ', straal ,
      ' 0 1,1 ', xs[2L], ' ', ys[2L] , '" stroke-width="', stroke.width,
      '" stroke="black" fill="none" ',
      'marker-start="url(#sarr)" marker-end="url(#arr)" />'
    ), zz)
    # label
    if (label != "") {
      writeLines(paste0('<text x="', middelpt[1L], '" y="', middelpt[2L],
                        '" text-anchor="middle" ',textattr, '>', labele,
                        '</text>'), zz)
    }
  }
  plot_node <- function(waar, tiepe, label = "") {
    labele <- lav_label_code(label,
                               idx.font.size = idx.font.size,
                               dy = dy,
                               auto.subscript = auto.subscript)$svg
    elems <- node_elements_svg(tiepe, nodedist * noderadius, waar, stroke.width)
    writeLines(c(
      elems$drawit,
      paste0('<text x="', waar[1], '" y="', waar[2], '" ',
              textattr, ' dominant-baseline="central" text-anchor="middle">',
             labele, '</text>')
    ), zz)
  }

  if (mlrij > 0L) {
    mlrij <- mlrij + lightness
    writeLines(paste0('<path d="M 1 ', mlrij * nodedist, ' L ',
                       (max(nodes$kolom) + lightness) * nodedist,
                      ' ', mlrij * nodedist, '" stroke="black"/>'),
               zz)
  }
  yrange <- nodedist * range(nodes$rij)
  xrange <- nodedist * range(nodes$kolom)
  midxy <- c(mean(xrange), mean(yrange))
  for (j in seq.int(nrow(edges))) {
    if (edges$naar[j] != edges$van[j]) {
      van <- which(nodes$id == edges$van[j])
      naar <- which(nodes$id == edges$naar[j])
      adrvan <- c(nodedist * nodes$kolom[van], nodedist * nodes$rij[van])
      elems <- node_elements_svg(nodes$tiepe[van], nodedist * noderadius,
                                 adrvan, stroke.width)
      adrvan <- elems[[edges$vananker[j]]]
      adrnaar <- c(nodedist * nodes$kolom[naar], nodedist * nodes$rij[naar])
      elems <- node_elements_svg(nodes$tiepe[naar], nodedist * noderadius,
                                 adrnaar, stroke.width)
      adrnaar <- elems[[edges$naaranker[j]]]
      if (is.na(edges$controlpt.rij[j])) {
        plot_edge(adrvan, adrnaar, edges$label[j],
                  dubbel = (edges$tiepe[j] == "~~"),
                  below = edges$labelbelow[j], id = j)
      } else {
        controlpt <- nodedist * c(edges$controlpt.kol[j] + 1,
                                  edges$controlpt.rij[j] + 1)
        plot_edge(adrvan, adrnaar, edges$label[j],
                  dubbel = (edges$tiepe[j] == "~~"),
                  below = edges$labelbelow[j],
                  control = controlpt,
                  id = j
        )
      }
    } else {
      van <- which(nodes$id == edges$van[j])
      adrvan <- c(nodedist * nodes$kolom[van], nodedist * nodes$rij[van])
      elems <- node_elements_svg(nodes$tiepe[van], nodedist * noderadius, adrvan, stroke.width)
      adrvan <- elems[[edges$vananker[j]]]
      plot_var(adrvan, noderadius * nodedist, edges$label[j], edges$vananker[j])
    }
  }
  for (j in seq.int(nrow(nodes))) {
    plot_node(nodedist * c(nodes$kolom[j], nodes$rij[j]),
              nodes$tiepe[j],
              nodes$naam[j])
  }
  writeLines("</svg>", zz)
  if (standalone) writeLines(c("</body>", "</html>"), zz)
  if (closezz) close(zz)
  return(invisible(NULL))
}

# user-visible function to extract the fit measures
# output can be 1) vector (default), 2) list, 3) matrix, or 4) text
# in the latter case, the result will be of class "lavaan.fitMeasures"
# for which the printing is done by lav_fitmeasures_print()

# new in 0.6-13:
# the big families are computed in dedicated functions:
# - lav_fit_rmsea_lavobject
# - lav_fit_cfi_lavobject
# - lav_fit_aic_lavojbect
# - lav_residuals_summary

# Note: fitMeasures/fitmeasures are generic functions; they include a "..."
#       so lavaan.mi can add arguments to pass to lavTestLRT() and
#       lavTestLRT.mi() about how to pool chi-squared.

setMethod(
  "fitMeasures", signature(object = "lavaan"),
  function(object, fit.measures = "all", baseline.model = NULL, h1.model = NULL,
           fm.args = list(
             standard.test = "default",
             scaled.test = "default",
             rmsea.ci.level = 0.90,
             rmsea.close.h0 = 0.05,
             rmsea.notclose.h0 = 0.08,
             robust = TRUE,
             cat.check.pd = TRUE
           ),
           output = "vector", ...) {
    dotdotdot <- list(...)
    if (length(dotdotdot) > 0L) {
      for (j in seq_along(dotdotdot)) {
        lav_msg_warn(gettextf(
          "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
          sQuote("fitMeasures"))
        )
      }
    }
    # note: the ... is not used by lavaan
    if (!is.list(fit.measures)) fit.measures <- list(fit.measures = fit.measures)
    if (!missing(fm.args)) fit.measures <- c(fit.measures, fm.args)
    lav_fit_measures(
      object = object, fit.measures = fit.measures,
      baseline.model = baseline.model, h1.model = h1.model,
      output = output
    )
  }
)

setMethod(
  "fitmeasures", signature(object = "lavaan"),
  function(object, fit.measures = "all", baseline.model = NULL, h1.model = NULL,
           fm.args = list(
             standard.test = "default",
             scaled.test = "default",
             rmsea.ci.level = 0.90,
             rmsea.close.h0 = 0.05,
             rmsea.notclose.h0 = 0.08,
             robust = TRUE,
             cat.check.pd = TRUE
           ),
           output = "vector", ...) {
    dotdotdot <- list(...)
    if (length(dotdotdot) > 0L) {
      for (j in seq_along(dotdotdot)) {
        lav_msg_warn(gettextf(
          "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
          sQuote("fitmeasures"))
        )
      }
    }
    # note: the ... is not used by lavaan
    if (!is.list(fit.measures)) fit.measures <- list(fit.measures = fit.measures)
    if (!missing(fm.args)) fit.measures <- c(fit.measures, fm.args)
    lav_fit_measures(
      object = object, fit.measures = fit.measures,
      baseline.model = baseline.model, h1.model = h1.model,
      output = output
    )
  }
)

# S3 method for efaList
lav_efalist_fitmeasures <- function(
    object,
    fit.measures = "all",
    baseline.model = NULL, h1.model = NULL,
    fm.args = list(
      standard.test = "default",
      scaled.test = "default",
      rmsea.ci.level = 0.90,
      rmsea.close.h0 = 0.05,
      rmsea.notclose.h0 = 0.08,
      robust = TRUE,
      cat.check.pd = TRUE
    ),
    output = "list", ...) {
  # kill object$loadings if present
  object[["loadings"]] <- NULL

  # get fit measures for each model
  if (!is.list(fit.measures)) fit.measures <- list(fit.measures = fit.measures)
  if (!missing(fm.args)) fit.measures <- c(fit.measures, fm.args)
  res <- simplify2array(lapply(
    object,
    function(x) {
      lav_fit_measures(
        object = x,
        fit.measures = fit.measures, h1.model = h1.model,
        baseline.model = baseline.model,
        output = "vector"
      )
    }
  )
  )

  # check if res is a matrix
  if (!is.matrix(res)) {
    if (is.numeric(res)) {
      # fit.measures is just 1 element, or only one was correct
      NAME <- names(res)[1]
      res <- matrix(res, nrow = 1L)
      rownames(res) <- NAME
    } else { # wrong fit measures?
      # create empty matrix
      res <- matrix(0, nrow = 0L, ncol = length(object))
    }
  }

  # rownames
  nfactors <- sapply(object, function(x) x@pta$nfac[[1]])
  colnames(res) <- paste0("nfactors = ", nfactors)

  # class
  class(res) <- c("lavaan.matrix", "matrix")

  res
}


lav_fit_measures <- function(object, fit.measures = "all",
                             baseline.model = NULL, h1.model = NULL,
                             fm.args = list(
                               standard.test = "default",
                               scaled.test = "default",
                               rmsea.ci.level = 0.90,
                               rmsea.close.h0 = 0.05,
                               rmsea.notclose.h0 = 0.08,
                               robust = TRUE,
                               cat.check.pd = TRUE
                             ),
                             output = "vector") {
  # check object
  object <- lav_object_check_version(object)

  # default fm.args
  default.fm.args <- list(
    standard.test = "default",
    scaled.test = "default",
    rmsea.ci.level = 0.90,
    rmsea.close.h0 = 0.05,
    rmsea.notclose.h0 = 0.08,
    robust = TRUE,
    cat.check.pd = TRUE
  )
  if (!missing(fm.args)) {
    lav_deprecated_args("fit.measures", "fm.args")
    fm.args <- modifyList(default.fm.args, fm.args)
  } else {
    fm.args <- default.fm.args
  }
  if (is.list(fit.measures)) {
    if (is.null(names(fit.measures)) ||
        is.null(fit.measures$fit.measures)) {
      lav_msg_stop(gettextf(
        "If %s is a list, it must contain a named element %s.",
        "fit.measures"
      ))
    }
    temp <- fit.measures$fit.measures
    fit.measures$fit.measures <- NULL
    fm.args <- modifyList(default.fm.args, fit.measures)
    fit.measures <- temp
  }

  # standard test
  if (fm.args$standard.test == "default") {
    fm.args$standard.test <- object@Options$standard.test
    # usually "standard", but could have been changed
    if (is.null(fm.args$standard.test)) { # <older objects
      fm.args$standard.test <- "standard"
    }
  }

  # scaled test
  if (fm.args$scaled.test == "default") {
    fm.args$scaled.test <- object@Options$scaled.test
    # usually "standard", but could have been changed
    if (is.null(fm.args$scaled.test)) { # <older objects
      fm.args$scaled.test <- "standard"
    }
  }

  # do we have data? (yep, we had to include this check)
  if (object@Data@data.type == "none") {
    lav_msg_stop(gettext("fit measures not available if there is no data."))
  }

  # has the model converged?
  if (object@optim$npar > 0L && !object@optim$converged) {
    lav_msg_stop(gettext(
      "fit measures not available if model did not converge"))
  }

  # do we have a test statistic?
  TEST <- lavInspect(object, "test")
  test.names <- unname(sapply(TEST, "[[", "test"))
  if (test.names[1] == "none") {
    lav_msg_stop(gettext("fit measures not available if test = \"none\"."))
    #FIXME: allow RMRs, log.likelihoods, info criteria, npar, ntotal
  }

  standard.test <- fm.args$standard.test
  scaled.test <- fm.args$scaled.test

  # check standard.test
  standard.test <- lav_test_rename(standard.test, check = TRUE)[1] # only 1

  # check scaled.test
  if (!scaled.test %in% c("none", "default", "standard")) {
    scaled.test <- lav_test_rename(scaled.test, check = TRUE)[1] # only 1
  }

  # which test statistic do we need?
  rerun.lavtest.flag <- FALSE
  if (!standard.test %in% test.names) {
    rerun.lavtest.flag <- TRUE
  }
  if (!scaled.test %in% c("none", "default", "standard") &&
      !scaled.test %in% test.names) {
    rerun.lavtest.flag <- TRUE
  }

  # do we have a scaled test statistic? if so, which one?
  scaled.flag <- FALSE
  if (scaled.test != "none" &&
      any(test.names %in% c(
        "satorra.bentler",
        "yuan.bentler", "yuan.bentler.mplus",
        "mean.var.adjusted", "scaled.shifted"
      ))) {
    scaled.flag <- TRUE
    if (scaled.test %in% c("standard", "default")) {
      tmp.idx <- which(test.names %in% c(
        "satorra.bentler",
        "yuan.bentler", "yuan.bentler.mplus",
        "mean.var.adjusted", "scaled.shifted"
      ))
      scaled.test <- test.names[tmp.idx[1]]
    }
  }

  # rerun lavTest?
  if (rerun.lavtest.flag) {
    this.test <- standard.test
    if (scaled.flag) {
      this.test <- unique(this.test, scaled.test)
    }
    TEST <- lavTest(object,
                    test = this.test, scaled.test = standard.test,
                    drop.list.single = FALSE
    )
    # replace in object, if we pass it to lav_fit_* functions
    object@test <- TEST
    test.names <- unname(sapply(TEST, "[[", "test"))
  }


  # TDJ: Check for user-supplied h1 model
  #      Similar to BASELINE model, use the following priority:
  #        1. user-provided h1 model
  #        2. h1 model in @external slot
  #        3. default h1 model (already in @h1 slot, no update necessary)

  user_h1_exists <- FALSE
  # 1. user-provided h1 model
  if (!is.null(h1.model)) {
    stopifnot(inherits(h1.model, "lavaan"))
    user_h1_exists <- TRUE

    # 2. h1 model in @external slot
  } else if (!is.null(object@external$h1.model)) {
    stopifnot(inherits(object@external$h1.model, "lavaan"))
    h1.model <- object@external$h1.model
    user_h1_exists <- TRUE
  }

  ## Update statistics in @test slot?
  if (user_h1_exists) {
    ## update @test slot
    FIT <- lav_update_test_custom_h1(lav_obj_h0 = object, lav_obj_h1 = h1.model)

    ## re-assign TEST object that is used below
    object@test <- TEST <- FIT@test
    test.names <- unname(sapply(TEST, "[[", "test"))
  }

  # get index of standard.test in TEST
  test.idx <- which(test.names == standard.test)[1]

  # get index of scaled test (if any) in TEST
  if (scaled.flag) {
    scaled.idx <- which(test.names == scaled.test)[1]
  }

  # check output argument
  if (output %in% c("vector", "horizontal")) {
    output <- "vector"
  } else if (output %in% c("list")) {
    output <- "list"
  } else if (output %in% c("matrix", "vertical")) {
    output <- "matrix"
  } else if (output %in% c("text", "pretty", "summary")) {
    output <- "text"
  } else {
    lav_msg_stop(gettextf("output should be %s.",
                          lav_msg_view(c("vector", "list", "matrix", "text"), "none", FALSE)
    ))
  }

  # options
  categorical.flag <- object@Model@categorical
  fiml.flag <- (fm.args$robust &&
                  object@Options$missing %in% c("ml", "ml.x"))
  estimator <- object@Options$estimator

  # basic ingredients
  X2 <- TEST[[test.idx]]$stat
  df <- TEST[[test.idx]]$df
  if (scaled.flag) {
    X2.scaled <- TEST[[scaled.idx]]$stat
    df.scaled <- TEST[[scaled.idx]]$df
  }
  npar <- lav_object_inspect_npar(object = object, ceq = TRUE)
  N <- lav_object_inspect_ntotal(object = object) # N vs N-1


  # define 'sets' of fit measures:
  fit.always <- c("npar")

  # basic chi-square test
  fit.chisq <- c("fmin", "chisq", "df", "pvalue")
  if (scaled.flag) {
    fit.chisq <- c(
      fit.chisq, "chisq.scaled", "df.scaled", "pvalue.scaled",
      "chisq.scaling.factor"
    )
  }

  # baseline model
  fit.baseline <- c("baseline.chisq", "baseline.df", "baseline.pvalue")
  if (scaled.flag) {
    fit.baseline <- c(
      fit.baseline, "baseline.chisq.scaled",
      "baseline.df.scaled", "baseline.pvalue.scaled",
      "baseline.chisq.scaling.factor"
    )
  }

  fit.cfi.tli <- c("cfi", "tli")
  if (scaled.flag) {
    fit.cfi.tli <- c(fit.cfi.tli, "cfi.scaled", "tli.scaled")
  }
  if (fm.args$robust && (scaled.flag || categorical.flag || fiml.flag)) {
    fit.cfi.tli <- c(fit.cfi.tli, "cfi.robust", "tli.robust")
  }

  # other incremental fit indices
  fit.cfi.other <- c("nnfi", "rfi", "nfi", "pnfi", "ifi", "rni")
  if (scaled.flag) {
    fit.cfi.other <- c(
      fit.cfi.other, "nnfi.scaled", "rfi.scaled",
      "nfi.scaled", "pnfi.scaled", "ifi.scaled", "rni.scaled"
    )
  }
  if (fm.args$robust && (scaled.flag || categorical.flag || fiml.flag)) {
    fit.cfi.other <- c(fit.cfi.other, "nnfi.robust", "rni.robust")
  }
  fit.cfi <- c(fit.baseline, fit.cfi.tli, fit.cfi.other)

  # likelihood based measures
  if (estimator == "MML") {
    fit.logl <- c("logl", "aic", "bic", "ntotal", "bic2")
  } else {
    fit.logl <- c(
      "logl", "unrestricted.logl", "aic", "bic",
      "ntotal", "bic2"
    )
  }
  if (scaled.flag &&
      scaled.test %in% c("yuan.bentler", "yuan.bentler.mplus")) {
    fit.logl <- c(fit.logl, "scaling.factor.h1", "scaling.factor.h0")
  }

  # rmsea
  fit.rmsea <- c(
    "rmsea",
    "rmsea.ci.lower", "rmsea.ci.upper", "rmsea.ci.level",
    "rmsea.pvalue", "rmsea.close.h0",
    "rmsea.notclose.pvalue", "rmsea.notclose.h0"
  )
  if (scaled.flag) {
    fit.rmsea <- c(
      fit.rmsea, "rmsea.scaled", "rmsea.ci.lower.scaled",
      "rmsea.ci.upper.scaled", "rmsea.pvalue.scaled",
      "rmsea.notclose.pvalue.scaled"
    )
  }
  if (fm.args$robust && (scaled.flag || categorical.flag || fiml.flag)) {
    fit.rmsea <- c(
      fit.rmsea, "rmsea.robust", "rmsea.ci.lower.robust",
      "rmsea.ci.upper.robust", "rmsea.pvalue.robust",
      "rmsea.notclose.pvalue.robust"
    )
  }

  # srmr
  if (categorical.flag) {
    fit.srmr <- c("srmr")
    fit.srmr2 <- c(
      "rmr", "rmr_nomean",
      "srmr", # per default equal to srmr_bentler_nomean
      "srmr_bentler", "srmr_bentler_nomean",
      "crmr", "crmr_nomean",
      "srmr_mplus", "srmr_mplus_nomean"
    )
  } else {
    if (object@Data@nlevels > 1L) {
      fit.srmr <- c("srmr", "srmr_within", "srmr_between")
      fit.srmr2 <- c("srmr", "srmr_within", "srmr_between")
    } else {
      fit.srmr <- c("srmr")
      fit.srmr2 <- c(
        "rmr", "rmr_nomean",
        "srmr", # the default
        "srmr_bentler", "srmr_bentler_nomean",
        "crmr", "crmr_nomean",
        "srmr_mplus", "srmr_mplus_nomean"
      )
    }
  }

  # various
  if (object@Data@nlevels > 1L) {
    fit.other <- ""
  } else if (estimator == "PML") {
    fit.other <- c("cn_05", "cn_01", "mfi")
    if (!categorical.flag) { # really needed?
      fit.other <- c(fit.other, "ecvi")
    }
  } else {
    fit.other <- c("cn_05", "cn_01", "gfi", "agfi", "pgfi", "mfi")
    if (!categorical.flag) { # really needed?
      fit.other <- c(fit.other, "ecvi")
    } else {
      fit.other <- c(fit.other, "wrmr")
    }
  }

  # lower case
  fit.measures <- fit.measures.orig <- tolower(fit.measures)

  # select 'default' fit measures
  if (length(fit.measures) == 1L) {
    if (fit.measures == "default") {
      if (estimator == "ML" || estimator == "PML") {
        fit.measures <- c(
          fit.always, fit.chisq, fit.baseline,
          fit.cfi.tli, fit.logl,
          fit.rmsea, fit.srmr
        )
      } else if (estimator == "MML") {
        fit.measures <- c(fit.always, fit.logl)
      } else {
        fit.measures <- c(
          fit.always,
          fit.chisq, fit.baseline, fit.cfi.tli,
          fit.rmsea, fit.srmr
        )
      }
    } else if (fit.measures == "all") {
      if (estimator == "ML") {
        fit.measures <- c(
          fit.always, fit.chisq,
          fit.baseline, fit.cfi.tli, fit.cfi.other,
          fit.logl, fit.rmsea, fit.srmr2, fit.other
        )
      } else {
        fit.measures <- c(
          fit.always, fit.chisq,
          fit.baseline, fit.cfi.tli, fit.cfi.other,
          fit.rmsea, fit.srmr2, fit.other
        )
      }
    }
  }

  # catch empty list
  if (length(fit.measures) == 0L) {
    return(list())
  }

  # main container
  indices <- list()
  indices["npar"] <- npar
  indices["ntotal"] <- object@SampleStats@ntotal
  indices["fmin"] <- object@optim$fx # note = 0.5 * fmin if ML

  # CHI-SQUARE TEST
  if (any(fit.chisq %in% fit.measures)) {
    indices["chisq"] <- X2
    indices["df"] <- df
    indices["pvalue"] <- TEST[[test.idx]]$pvalue
    if (scaled.flag) {
      indices["chisq.scaled"] <- X2.scaled
      indices["df.scaled"] <- df.scaled
      indices["chisq.scaling.factor"] <- TEST[[scaled.idx]]$scaling.factor
      indices["pvalue.scaled"] <- TEST[[scaled.idx]]$pvalue
    }
  }

  # BASELINE FAMILY
  if (any(fit.cfi %in% fit.measures)) {

    # rerun baseline?
    if (rerun.lavtest.flag) {
      object@Options$test <- this.test
      fit.indep <- try(lav_object_independence(object), silent = TRUE)
      # override object
      object@baseline$test <- fit.indep@test
    }

    indices <- c(
      indices,
      lav_fit_cfi_lavobject(
        lavobject = object,
        fit.measures = fit.measures,
        baseline.model = baseline.model,
        h1.model = h1.model,
        standard.test = standard.test,
        scaled.test = scaled.test,
        robust = fm.args$robust,
        cat.check.pd = fm.args$cat.check.pd
      )
    )
  }

  # INFORMATION CRITERIA
  if (any(fit.logl %in% fit.measures)) {
    indices <- c(
      indices,
      lav_fit_aic_lavobject(
        lavobject = object,
        fit.measures = fit.measures,
        standard.test = standard.test,
        scaled.test = scaled.test,
        estimator = estimator
      )
    )
  }

  # RMSEA and friends
  if (any(fit.rmsea %in% fit.measures)) {
    # check rmsea options
    rmsea.ci.level <- 0.90
    rmsea.close.h0 <- 0.05
    rmsea.notclose.h0 <- 0.08
    if (!is.null(fm.args$rmsea.ci.level) &&
        is.finite(fm.args$rmsea.ci.level)) {
      rmsea.ci.level <- fm.args$rmsea.ci.level
      if (rmsea.ci.level < 0 || rmsea.ci.level > 1.0) {
        lav_msg_warn(gettextf(
          "invalid rmsea.ci.level value [%s] set to default 0.90.",
          rmsea.ci.level))
        rmsea.ci.level <- 0.90
      }
    }
    if (!is.null(fm.args$rmsea.close.h0) &&
        is.finite(fm.args$rmsea.close.h0)) {
      rmsea.close.h0 <- fm.args$rmsea.close.h0
      if (rmsea.close.h0 < 0) {
        rmsea.close.h0 <- 0
      }
    }
    if (!is.null(fm.args$rmsea.notclose.h0) &&
        is.finite(fm.args$rmsea.notclose.h0)) {
      rmsea.notclose.h0 <- fm.args$rmsea.notclose.h0
      if (rmsea.notclose.h0 < 0) {
        rmsea.notclose.h0 <- 0
      }
    }
    indices <- c(
      indices,
      lav_fit_rmsea_lavobject(
        lavobject = object,
        fit.measures = fit.measures,
        standard.test = standard.test,
        scaled.test = scaled.test,
        ci.level = rmsea.ci.level,
        close.h0 = rmsea.close.h0,
        notclose.h0 = rmsea.notclose.h0,
        robust = fm.args$robust,
        cat.check.pd = fm.args$cat.check.pd
      )
    )
  }

  # SRMR and friends
  if (any(fit.srmr2 %in% fit.measures)) {
    indices <- c(
      indices,
      lav_fit_srmr_lavobject(
        lavobject = object,
        fit.measures = fit.measures
      )
    )
  }

  # GFI and friends
  fit.gfi <- c("gfi", "agfi", "pgfi")
  if (any(fit.gfi %in% fit.measures)) {
    indices <- c(
      indices,
      lav_fit_gfi_lavobject(
        lavobject = object,
        fit.measures = fit.measures
      )
    )
  }

  # various: Hoelter Critical N (CN)
  if (any(c("cn_05", "cn_01") %in% fit.measures)) {
    indices["cn_05"] <- lav_fit_cn(X2 = X2, df = df, N = N, alpha = 0.05)
    indices["cn_01"] <- lav_fit_cn(X2 = X2, df = df, N = N, alpha = 0.01)
  }

  # various: WRMR
  if ("wrmr" %in% fit.measures) {
    nel <- length(object@SampleStats@WLS.obs[[1]])
    indices["wrmr"] <- lav_fit_wrmr(X2 = X2, nel = nel)
  }

  # various: MFI
  if ("mfi" %in% fit.measures) {
    indices["mfi"] <- lav_fit_mfi(X2 = X2, df = df, N = N)
  }

  # various: ECVI
  if ("ecvi" %in% fit.measures) {
    indices["ecvi"] <- lav_fit_ecvi(X2 = X2, npar = npar, N = N)
  }


  # keep only what we need
  out <- indices[fit.measures]

  if (all(is.na(names(out)))) { # perhaps, fit.measures = ""
    # nothing left
    return(numeric(0L))
  }

  # select output type
  if (output == "list") {
    # nothing to do
  } else if (output == "vector") {
    out <- unlist(out)
    class(out) <- c("lavaan.vector", "numeric")
  } else if (output == "matrix") {
    out <- as.matrix(unlist(out))
    colnames(out) <- ""
    class(out) <- c("lavaan.matrix", "matrix")
  } else if (output == "text") {
    out <- unlist(out)
    class(out) <- c("lavaan.fitMeasures", "lavaan.vector", "numeric")
  }

  # attributes?
  # only if fit.measures == "all" or "default"
  if (length(fit.measures.orig) == 1L &&
      fit.measures.orig %in% c("all", "default")) {
    X2.label <- TEST[[test.idx]]$label # NULL if "standard"
    X2.baseline.label <- object@baseline$test[[test.idx]]$label
    attr(out, "X2.label") <- X2.label
    attr(out, "X2.baseline.label") <- X2.baseline.label
    if (standard.test != "standard") {
      attr(out, "standard.test") <- standard.test
    }
    if (scaled.flag && scaled.test != "standard") {
      attr(out, "scaled.test") <- scaled.test
    }
  }

  out
}

# print a nice summary of the fit measures
lav_fitmeasures_print <- function(x, ..., nd = 3L, add.h0 = TRUE) {
  names.x <- names(x)

  # scaled?
  scaled.flag <- "chisq.scaled" %in% names.x

  # num format
  num.format <- paste("%", max(8L, nd + 5L), ".", nd, "f", sep = "")

  ## TDJ: optionally add h0 model's fit statistic, for lavaan.mi
  if (add.h0 && "chisq" %in% names.x) {
    cat("\nModel Test User Model:\n\n")

    # container three columns
    c1 <- c2 <- c3 <- character(0L)

    # TDJ: Add header used in summary() by lavaan.mi
    if (scaled.flag) {
      c1 <- c("", c1)
      c2 <- c("Standard", c2)
      c3 <- c("Scaled", c3)
    }

    # if test is not standard, add label
    if (!is.null(attr(x, "X2.label"))) {
      c1 <- c(c1, attr(x, "X2.label"))
      c2 <- c(c2, "")
      c3 <- c(c3, "")
    }

    c1 <- c(c1, "Test statistic")
    c2 <- c(c2, sprintf(num.format, x["chisq"]))
    c3 <- c(c3, ifelse(scaled.flag,
                       sprintf(num.format, x["chisq.scaled"]), ""
    ))

    c1 <- c(c1, "Degrees of freedom")
    c2 <- c(c2, x["df"])
    c3 <- c(c3, ifelse(scaled.flag,
                       ifelse(x["df.scaled"] %% 1 == 0, x["df.scaled"],
                              sprintf(num.format, x["df.scaled"])
                       ), ""
    ))

    c1 <- c(c1, "P-value")
    c2 <- c(c2, sprintf(num.format, x["pvalue"]))
    c3 <- c(c3, ifelse(scaled.flag,
                       sprintf(num.format, x["pvalue.scaled"]), ""
    ))

    if (scaled.flag && "chisq.scaling.factor" %in% names.x) {
      c1 <- c(c1, "Average scaling correction factor")
      c2 <- c(c2, "")
      c3 <- c(c3, sprintf(num.format, x["chisq.scaling.factor"]))

      ## check for shift parameter
      chisq.shift.parameter <- attr(attr(x, "header"), "shift")
      if (!is.null(chisq.shift.parameter)) {
        c1 <- c(c1, "Average shift parameter",
                "  simple second-order correction")
        c2 <- c(c2, "", "")
        ## This is only provided by the fitMeasures() method for lavaan.mi-class
        c3 <- c(c3, sprintf(num.format, chisq.shift.parameter),
                "")
      }
    }

    # check for lavaan.mi attributes "pool.method" and "pool.robust"
    if (!is.null(attr(x, "pool.method"))) {
      ## extract information from lavaan.mi object about
      ## the method used to pool the test statistic
      pool.method   <- attr(     x           , "pool.method")
      pool.robust   <- attr(     x           , "pool.robust")
      standard.test <- attr(attr(x, "header"), "standard.test")
      scaled.test   <- attr(attr(x, "header"),   "scaled.test")

      c1 <- c(c1, "Pooling method")
      c2 <- c(c2, pool.method)
      c3 <- c(c3, "")

      ## (conditionally for D2 method) add other pooling information
      if (scaled.flag) {
        c1 <- c(c1, "  Pooled statistic")
        c2 <- c(c2, ifelse(pool.robust, dQuote(scaled.test), dQuote(standard.test)))
        c3 <- c(c3, "")

        if (pool.robust && pool.method == "D2") {
          c1 <- c(c1, paste0("  ", dQuote(scaled.test), " correction applied"))
          c2 <- c(c2, "BEFORE")
          c3 <- c(c3, "pooling")
        } else {
          c1 <- c(c1, paste0("  ", dQuote(scaled.test), " correction applied"))
          c2 <- c(c2, "AFTER")
          c3 <- c(c3, "pooling")
        }

      }
    }

    # format c1/c2/c3
    c1 <- format(c1, width = 35L)
    c2 <- format(c2, width = 16L + max(0, (nd - 3L)) * 4L, justify = "right")
    c3 <- format(c3, width = 8L + nd, justify = "right")

    # create character matrix
    if (scaled.flag) {
      M <- cbind(c1, c2, c3, deparse.level = 0)
    } else {
      M <- cbind(c1, c2, deparse.level = 0)
    }
    colnames(M) <- rep("", ncol(M))
    rownames(M) <- rep(" ", nrow(M))

    # print
    write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
  }

  # print information about standard.test? (new in 0.6-21)
  # (only if "standard.test" is not "standard")
  if (!is.null(attr(x, "standard.test"))) {
    cat("\nNote: fit measures based on the chi-square test statistic\n",
        "     use", attr(x, "X2.label"),"\n")
  }

  # independence model
  if ("baseline.chisq" %in% names.x) {
    cat("\nModel Test Baseline Model:\n\n")

    c1 <- c2 <- c3 <- character(0L)
    # if test is not standard, add label
    if (!is.null(attr(x, "X2.baseline.label"))) {
      c1 <- c(c1, attr(x, "X2.label"))
      c2 <- c(c2, "")
      c3 <- c(c3, "")
    }

    c1 <- c(c1, "Test statistic")
    c2 <- c(c2, sprintf(num.format, x["baseline.chisq"]))
    c3 <- c(c3, ifelse(scaled.flag,
                       sprintf(num.format, x["baseline.chisq.scaled"]), ""
    ))

    c1 <- c(c1, "Degrees of freedom")
    c2 <- c(c2, x["baseline.df"])
    c3 <- c(c3, ifelse(scaled.flag, ifelse(x["baseline.df.scaled"] %% 1 == 0,
                                           x["baseline.df.scaled"],
                                           sprintf(num.format, x["baseline.df.scaled"])
    ),
    ""
    ))

    c1 <- c(c1, "P-value")
    c2 <- c(c2, sprintf(num.format, x["baseline.pvalue"]))
    c3 <- c(c3, ifelse(scaled.flag,
                       sprintf(num.format, x["baseline.pvalue.scaled"]), ""
    ))

    if (scaled.flag && "baseline.chisq.scaling.factor" %in% names.x) {
      c1 <- c(c1, "Scaling correction factor")
      c2 <- c(c2, "")
      c3 <- c(c3, sprintf(num.format, x["baseline.chisq.scaling.factor"]))
    }

    # format c1/c2/c3
    c1 <- format(c1, width = 35L)
    c2 <- format(c2, width = 16L + max(0, (nd - 3L)) * 4L, justify = "right")
    c3 <- format(c3, width = 8L + nd, justify = "right")

    # create character matrix
    if (scaled.flag) {
      M <- cbind(c1, c2, c3, deparse.level = 0)
    } else {
      M <- cbind(c1, c2, deparse.level = 0)
    }
    colnames(M) <- rep("", ncol(M))
    rownames(M) <- rep(" ", nrow(M))

    # print
    write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
  }

  # cfi/tli
  if (any(c("cfi", "tli", "nnfi", "rfi", "nfi", "ifi", "rni", "pnfi") %in% names.x)) {
    cat("\nUser Model versus Baseline Model:\n\n")

    c1 <- c2 <- c3 <- character(0L)

    if ("cfi" %in% names.x) {
      c1 <- c(c1, "Comparative Fit Index (CFI)")
      c2 <- c(c2, sprintf(num.format, x["cfi"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["cfi.scaled"]), ""
      ))
    }

    if ("tli" %in% names.x) {
      c1 <- c(c1, "Tucker-Lewis Index (TLI)")
      c2 <- c(c2, sprintf(num.format, x["tli"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["tli.scaled"]), ""
      ))
    }

    if ("cfi.robust" %in% names.x) {
      c1 <- c(c1, "")
      c2 <- c(c2, "")
      c3 <- c(c3, "")
      c1 <- c(c1, "Robust Comparative Fit Index (CFI)")
      if (scaled.flag) {
        c2 <- c(c2, "")
        c3 <- c(c3, sprintf(num.format, x["cfi.robust"]))
      } else {
        c2 <- c(c2, sprintf(num.format, x["cfi.robust"]))
        c3 <- c(c3, "")
      }
    }

    if ("tli.robust" %in% names.x) {
      c1 <- c(c1, "Robust Tucker-Lewis Index (TLI)")
      if (scaled.flag) {
        c2 <- c(c2, "")
        c3 <- c(c3, sprintf(num.format, x["tli.robust"]))
      } else {
        c2 <- c(c2, sprintf(num.format, x["tli.robust"]))
        c3 <- c(c3, "")
      }
    }

    if ("nnfi" %in% names.x) {
      c1 <- c(c1, "Bentler-Bonett Non-normed Fit Index (NNFI)")
      c2 <- c(c2, sprintf(num.format, x["nnfi"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["nnfi.robust"]), ""
      ))
    }

    if ("nfi" %in% names.x) {
      c1 <- c(c1, "Bentler-Bonett Normed Fit Index (NFI)")
      c2 <- c(c2, sprintf(num.format, x["nfi"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["nfi.scaled"]), ""
      ))
    }

    if ("pnfi" %in% names.x) {
      c1 <- c(c1, "Parsimony Normed Fit Index (PNFI)")
      c2 <- c(c2, sprintf(num.format, x["pnfi"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["pnfi.scaled"]), ""
      ))
    }

    if ("rfi" %in% names.x) {
      c1 <- c(c1, "Bollen's Relative Fit Index (RFI)")
      c2 <- c(c2, sprintf(num.format, x["rfi"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["rfi.scaled"]), ""
      ))
    }

    if ("ifi" %in% names.x) {
      c1 <- c(c1, "Bollen's Incremental Fit Index (IFI)")
      c2 <- c(c2, sprintf(num.format, x["ifi"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["ifi.scaled"]), ""
      ))
    }

    if ("rni" %in% names.x) {
      c1 <- c(c1, "Relative Noncentrality Index (RNI)")
      c2 <- c(c2, sprintf(num.format, x["rni"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["rni.robust"]), ""
      ))
    }

    # format c1/c2/c3
    c1 <- format(c1, width = 43L)
    c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right")
    c3 <- format(c3, width = 8L + nd, justify = "right")

    # create character matrix
    if (scaled.flag) {
      M <- cbind(c1, c2, c3, deparse.level = 0)
    } else {
      M <- cbind(c1, c2, deparse.level = 0)
    }
    colnames(M) <- rep("", ncol(M))
    rownames(M) <- rep(" ", nrow(M))

    # print
    write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
  }

  # likelihood
  if ("logl" %in% names.x) {
    cat("\nLoglikelihood and Information Criteria:\n\n")

    c1 <- c2 <- c3 <- character(0L)

    c1 <- c(c1, "Loglikelihood user model (H0)")
    c2 <- c(c2, sprintf(num.format, x["logl"]))
    c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["logl"]), ""))
    if (!is.na(x["scaling.factor.h0"])) {
      c1 <- c(c1, "Scaling correction factor")
      c2 <- c(c2, sprintf("  %10s", ""))
      c3 <- c(c3, sprintf(num.format, x["scaling.factor.h0"]))
      c1 <- c(c1, "    for the MLR correction")
      c2 <- c(c2, "")
      c3 <- c(c3, "")
    }

    if ("unrestricted.logl" %in% names.x) {
      c1 <- c(c1, "Loglikelihood unrestricted model (H1)")
      c2 <- c(c2, sprintf(num.format, x["unrestricted.logl"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["unrestricted.logl"]), ""
      ))
      if (!is.na(x["scaling.factor.h1"])) {
        c1 <- c(c1, "Scaling correction factor")
        c2 <- c(c2, sprintf("  %10s", ""))
        c3 <- c(c3, sprintf(num.format, x["scaling.factor.h1"]))
        c1 <- c(c1, "    for the MLR correction")
        c2 <- c(c2, "")
        c3 <- c(c3, "")
      }
    }

    c1 <- c(c1, "")
    c2 <- c(c2, "")
    c3 <- c(c3, "")
    # c1 <- c(c1, "Number of free parameters")
    # c2 <- c(c2, sprintf("  %10i", x["npar"]))
    # c3 <- c(c3, ifelse(scaled, sprintf("  %10i", x["npar"]), ""))

    c1 <- c(c1, "Akaike (AIC)")
    c2 <- c(c2, sprintf(num.format, x["aic"]))
    c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["aic"]), ""))
    c1 <- c(c1, "Bayesian (BIC)")
    c2 <- c(c2, sprintf(num.format, x["bic"]))
    c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["bic"]), ""))
    if (!is.na(x["bic2"])) {
      c1 <- c(c1, "Sample-size adjusted Bayesian (SABIC)")
      c2 <- c(c2, sprintf(num.format, x["bic2"]))
      c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["bic2"]), ""))
    }

    # format c1/c2/c3
    c1 <- format(c1, width = 39L)
    c2 <- format(c2, width = 12L + max(0, (nd - 3L)) * 4L, justify = "right")
    c3 <- format(c3, width = 8L + nd, justify = "right")

    # create character matrix
    if (scaled.flag) {
      M <- cbind(c1, c2, c3, deparse.level = 0)
    } else {
      M <- cbind(c1, c2, deparse.level = 0)
    }
    colnames(M) <- rep("", ncol(M))
    rownames(M) <- rep(" ", nrow(M))

    # print
    write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
  }

  # RMSEA
  if ("rmsea" %in% names.x) {
    cat("\nRoot Mean Square Error of Approximation:\n\n")

    c1 <- c2 <- c3 <- character(0L)

    c1 <- c(c1, "RMSEA")
    c2 <- c(c2, sprintf(num.format, x["rmsea"]))
    c3 <- c(c3, ifelse(scaled.flag,
                       sprintf(num.format, x["rmsea.scaled"]), ""
    ))

    ci.level <- NULL
    if ("rmsea.ci.level" %in% names.x) {
      ci.level <- x["rmsea.ci.level"]
    }
    if ("rmsea.ci.lower" %in% names.x) {
      if (is.null(ci.level)) {
        c1 <- c(c1, "Confidence interval - lower")
      } else {
        c1 <- c(c1, paste0(
          sprintf("%2d", round(ci.level * 100)),
          " Percent confidence interval - lower"
        ))
      }
      c2 <- c(c2, sprintf(num.format, x["rmsea.ci.lower"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["rmsea.ci.lower.scaled"]), ""
      ))
      if (is.null(ci.level)) {
        c1 <- c(c1, "Confidence interval - upper")
      } else {
        c1 <- c(c1, paste0(
          sprintf("%2d", round(ci.level * 100)),
          " Percent confidence interval - upper"
        ))
      }
      c2 <- c(c2, sprintf(num.format, x["rmsea.ci.upper"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["rmsea.ci.upper.scaled"]), ""
      ))
    }

    rmsea.close.h0 <- NULL
    if ("rmsea.close.h0" %in% names.x) {
      rmsea.close.h0 <- x["rmsea.close.h0"]
    }
    rmsea.notclose.h0 <- NULL
    if ("rmsea.notclose.h0" %in% names.x) {
      rmsea.notclose.h0 <- x["rmsea.notclose.h0"]
    }
    if ("rmsea.pvalue" %in% names.x) {
      if (is.null(rmsea.close.h0)) {
        c1 <- c(c1, "P-value H_0: RMSEA <= 0.05")
      } else {
        c1 <- c(c1, paste0(
          "P-value H_0: RMSEA <= ",
          sprintf("%4.3f", rmsea.close.h0)
        ))
      }
      c2 <- c(c2, sprintf(num.format, x["rmsea.pvalue"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["rmsea.pvalue.scaled"]), ""
      ))
    }
    if ("rmsea.notclose.pvalue" %in% names.x) {
      if (is.null(rmsea.notclose.h0)) {
        c1 <- c(c1, "P-value H_0: RMSEA >= 0.080")
      } else {
        c1 <- c(c1, paste0(
          "P-value H_0: RMSEA >= ",
          sprintf("%4.3f", rmsea.notclose.h0)
        ))
      }
      c2 <- c(c2, sprintf(num.format, x["rmsea.notclose.pvalue"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["rmsea.notclose.pvalue.scaled"]), ""
      ))
    }

    # robust
    if ("rmsea.robust" %in% names.x) {
      c1 <- c(c1, "")
      c2 <- c(c2, "")
      c3 <- c(c3, "")
      c1 <- c(c1, "Robust RMSEA")
      if (scaled.flag) {
        c2 <- c(c2, "")
        c3 <- c(c3, sprintf(num.format, x["rmsea.robust"]))
      } else {
        c2 <- c(c2, sprintf(num.format, x["rmsea.robust"]))
        c3 <- c(c3, "")
      }
    }
    if ("rmsea.ci.lower.robust" %in% names.x) {
      if (is.null(ci.level)) {
        c1 <- c(c1, "Confidence interval - lower")
      } else {
        c1 <- c(c1, paste0(
          sprintf("%2d", round(ci.level * 100)),
          " Percent confidence interval - lower"
        ))
      }
      if (scaled.flag) {
        c2 <- c(c2, "")
        c3 <- c(c3, sprintf(num.format, x["rmsea.ci.lower.robust"]))
      } else {
        c2 <- c(c2, sprintf(num.format, x["rmsea.ci.lower.robust"]))
        c3 <- c(c3, "")
      }

      if (is.null(ci.level)) {
        c1 <- c(c1, "Confidence interval - upper")
      } else {
        c1 <- c(c1, paste0(
          sprintf("%2d", round(ci.level * 100)),
          " Percent confidence interval - upper"
        ))
      }
      if (scaled.flag) {
        c2 <- c(c2, "")
        c3 <- c(c3, sprintf(num.format, x["rmsea.ci.upper.robust"]))
      } else {
        c2 <- c(c2, sprintf(num.format, x["rmsea.ci.upper.robust"]))
        c3 <- c(c3, "")
      }
    }
    if ("rmsea.pvalue.robust" %in% names.x) {
      if (is.null(rmsea.close.h0)) {
        c1 <- c(c1, "P-value H_0: Robust RMSEA <= 0.05")
      } else {
        c1 <- c(c1, paste0(
          "P-value H_0: Robust RMSEA <= ",
          sprintf("%4.3f", rmsea.close.h0)
        ))
      }
      if (scaled.flag) {
        c2 <- c(c2, "")
        c3 <- c(c3, sprintf(num.format, x["rmsea.pvalue.robust"]))
      } else {
        c2 <- c(c2, sprintf(num.format, x["rmsea.pvalue.robust"]))
        c3 <- c(c3, "")
      }
    }
    if ("rmsea.notclose.pvalue.robust" %in% names.x) {
      if (is.null(rmsea.notclose.h0)) {
        c1 <- c(c1, "P-value H_0: Robust RMSEA >= 0.080")
      } else {
        c1 <- c(c1, paste0(
          "P-value H_0: Robust RMSEA >= ",
          sprintf("%4.3f", rmsea.notclose.h0)
        ))
      }
      if (scaled.flag) {
        c2 <- c(c2, "")
        c3 <- c(
          c3,
          sprintf(num.format, x["rmsea.notclose.pvalue.robust"])
        )
      } else {
        c2 <- c(
          c2,
          sprintf(num.format, x["rmsea.notclose.pvalue.robust"])
        )
        c3 <- c(c3, "")
      }
    }

    # format c1/c2/c3
    c1 <- format(c1, width = 43L)
    c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right")
    c3 <- format(c3, width = 8L + nd, justify = "right")

    # create character matrix
    if (scaled.flag) {
      M <- cbind(c1, c2, c3, deparse.level = 0)
    } else {
      M <- cbind(c1, c2, deparse.level = 0)
    }
    colnames(M) <- rep("", ncol(M))
    rownames(M) <- rep(" ", nrow(M))

    # print
    write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
  }

  # SRMR
  #TODO: add CRMR
  if (any(c("rmr", "srmr") %in% names.x) && !"srmr_within" %in% names.x) {
    cat("\nStandardized Root Mean Square Residual:\n\n")

    c1 <- c2 <- c3 <- character(0L)

    if ("rmr" %in% names.x) {
      c1 <- c(c1, "RMR")
      c2 <- c(c2, sprintf(num.format, x["rmr"]))
      c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["rmr"]), ""))
    }
    if ("rmr_nomean" %in% names.x) {
      c1 <- c(c1, "RMR (No Mean)")
      c2 <- c(c2, sprintf(num.format, x["rmr_nomean"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["rmr_nomean"]), ""
      ))
    }
    if ("srmr" %in% names.x) {
      c1 <- c(c1, "SRMR")
      c2 <- c(c2, sprintf(num.format, x["srmr"]))
      c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["srmr"]), ""))
    }
    if ("srmr_nomean" %in% names.x) {
      c1 <- c(c1, "SRMR (No Mean)")
      c2 <- c(c2, sprintf(num.format, x["srmr_nomean"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["srmr_nomean"]), ""
      ))
    }

    # format c1/c2/c3
    c1 <- format(c1, width = 43L)
    c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right")
    c3 <- format(c3, width = 8L + nd, justify = "right")

    # create character matrix
    if (scaled.flag) {
      M <- cbind(c1, c2, c3, deparse.level = 0)
    } else {
      M <- cbind(c1, c2, deparse.level = 0)
    }
    colnames(M) <- rep("", ncol(M))
    rownames(M) <- rep(" ", nrow(M))

    # print
    write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
  }

  # SRMR -- multilevel
  #TODO: add CRMR?
  if (any(c("srmr_within", "srmr_between") %in% names.x)) {
    cat("\nStandardized Root Mean Square Residual (corr metric):\n\n")

    c1 <- c2 <- c3 <- character(0L)

    if ("srmr_within" %in% names.x) {
      c1 <- c(c1, "SRMR (within covariance matrix)")
      c2 <- c(c2, sprintf(num.format, x["srmr_within"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["srmr_within"]), ""
      ))
    }
    if ("srmr_between" %in% names.x) {
      c1 <- c(c1, "SRMR (between covariance matrix)")
      c2 <- c(c2, sprintf(num.format, x["srmr_between"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["srmr_between"]), ""
      ))
    }

    # format c1/c2/c3
    c1 <- format(c1, width = 43L)
    c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right")
    c3 <- format(c3, width = 8L + nd, justify = "right")

    # create character matrix
    if (scaled.flag) {
      M <- cbind(c1, c2, c3, deparse.level = 0)
    } else {
      M <- cbind(c1, c2, deparse.level = 0)
    }
    colnames(M) <- rep("", ncol(M))
    rownames(M) <- rep(" ", nrow(M))

    # print
    write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
  }

  # WRMR
  if ("wrmr" %in% names.x) {
    cat("\nWeighted Root Mean Square Residual:\n\n")

    c1 <- c2 <- c3 <- character(0L)

    if ("wrmr" %in% names.x) {
      c1 <- c(c1, "WRMR")
      c2 <- c(c2, sprintf(num.format, x["wrmr"]))
      c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["wrmr"]), ""))
    }

    # format c1/c2/c3
    c1 <- format(c1, width = 43L)
    c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right")
    c3 <- format(c3, width = 8L + nd, justify = "right")

    # create character matrix
    if (scaled.flag) {
      M <- cbind(c1, c2, c3, deparse.level = 0)
    } else {
      M <- cbind(c1, c2, deparse.level = 0)
    }
    colnames(M) <- rep("", ncol(M))
    rownames(M) <- rep(" ", nrow(M))

    # print
    write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
  }

  # Other
  if (any(c("cn_05", "cn_01", "gfi", "agfi", "pgfi", "mfi") %in% names.x)) {
    cat("\nOther Fit Indices:\n\n")

    c1 <- c2 <- c3 <- character(0L)

    if ("cn_05" %in% names.x) {
      c1 <- c(c1, "Hoelter Critical N (CN) alpha = 0.05")
      c2 <- c(c2, sprintf(num.format, x["cn_05"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["cn_05"]), ""
      ))
    }
    if ("cn_01" %in% names.x) {
      c1 <- c(c1, "Hoelter Critical N (CN) alpha = 0.01")
      c2 <- c(c2, sprintf(num.format, x["cn_01"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["cn_01"]), ""
      ))
    }
    if (any(c("cn_05", "cn_01") %in% names.x)) {
      c1 <- c(c1, "")
      c2 <- c(c2, "")
      c3 <- c(c3, "")
    }
    if ("gfi" %in% names.x) {
      c1 <- c(c1, "Goodness of Fit Index (GFI)")
      c2 <- c(c2, sprintf(num.format, x["gfi"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["gfi"]), ""
      ))
    }
    if ("agfi" %in% names.x) {
      c1 <- c(c1, "Adjusted Goodness of Fit Index (AGFI)")
      c2 <- c(c2, sprintf(num.format, x["agfi"]))
      c3 <- c(c3, ifelse(scaled.flag,
                         sprintf(num.format, x["agfi"]), ""
      ))
    }
    if ("pgfi" %in% names.x) {
      c1 <- c(c1, "Parsimony Goodness of Fit Index (PGFI)")
      c2 <- c(c2, sprintf(num.format, x["pgfi"]))
      c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["pgfi"]), ""))
    }
    if (any(c("gfi", "agfi", "pgfi") %in% names.x)) {
      c1 <- c(c1, "")
      c2 <- c(c2, "")
      c3 <- c(c3, "")
    }
    if ("mfi" %in% names.x) {
      c1 <- c(c1, "McDonald Fit Index (MFI)")
      c2 <- c(c2, sprintf(num.format, x["mfi"]))
      c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["mfi"]), ""))
    }
    if ("mfi" %in% names.x) {
      c1 <- c(c1, "")
      c2 <- c(c2, "")
      c3 <- c(c3, "")
    }
    if ("ecvi" %in% names.x) {
      c1 <- c(c1, "Expected Cross-Validation Index (ECVI)")
      c2 <- c(c2, sprintf(num.format, x["ecvi"]))
      c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["ecvi"]), ""))
    }

    # format c1/c2/c3
    c1 <- format(c1, width = 43L)
    c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right")
    c3 <- format(c3, width = 8L + nd, justify = "right")

    # create character matrix
    if (scaled.flag) {
      M <- cbind(c1, c2, c3, deparse.level = 0)
    } else {
      M <- cbind(c1, c2, deparse.level = 0)
    }
    colnames(M) <- rep("", ncol(M))
    rownames(M) <- rep(" ", nrow(M))

    # print
    write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
  }

  invisible(x)
}

# build a bare-bones parameter table from a fitted lm object
#
# YR: this function was broken since Mar 3, 2017, but nobody noticed this!
#     fixed again Apr 29, 2025.

lav_partable_from_lm <- function(object, est = FALSE, label = FALSE,
                                 as.data.frame. = FALSE) {
  # sanity check
  if (!inherits(object, "lm")) {
    lav_msg_stop(gettext("object must be of class lm"))
  }

  objectTerms <- terms(object)

  responseIndex <- attr(objectTerms, "response")
  varNames <- as.character(attr(objectTerms, "variables"))[-1]
  responseName <- varNames[responseIndex]

  predCoef <- coef(object)
  predNames <- names(predCoef)

  lhs <- rep(responseName, length(predNames))
  op <- rep("~", length(predNames))
  rhs <- predNames

  # intercept?
  if (attr(objectTerms, "intercept")) {
    int.idx <- which(rhs == "(Intercept)")
    op[int.idx] <- "~1"
    rhs[int.idx] <- ""
  }

  # always add residual variance?
  # lhs <- c(lhs, responseName)
  # op <- c(op, "~~")
  # rhs <- c(rhs, responseName)

  # construct minimal partable
  partable <- list(lhs = lhs, op = op, rhs = rhs)

  # include 'est' column?
  if (est) {
    # partable$est <- c(as.numeric(predCoef),
    #                  sum(resid(object)^2) / object$df.residual)
    partable$est <- as.numeric(predCoef)
  }

  # include 'label' column?
  if (label) {
    # partable$label <- c(predNames, responseName)
    partable$label <- predNames

    # convert all ':' to '.'
    partable$label <- gsub("[:()]", ".", partable$label)
  }

  # convert to data.frame?
  if (as.data.frame.) {
    partable <- as.data.frame(partable, stringsAsFactors = FALSE)
  }

  partable
}

# model objective

lav_model_objective <- function(lavmodel = NULL,
                                GLIST = NULL,
                                lavsamplestats = NULL,
                                lavdata = NULL,
                                lavcache = NULL) {
  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST

  # shortcut for data.type == "none" or estimator == "none"
  if (lavmodel@estimator == "none" || length(lavsamplestats@cov) == 0L) {
    fx <- as.numeric(NA)
    attr(fx, "fx.group") <- rep(as.numeric(NA), lavsamplestats@ngroups)
    return(fx)
  }

  meanstructure <- lavmodel@meanstructure
  estimator <- lavmodel@estimator
  categorical <- lavmodel@categorical
  correlation <- lavmodel@correlation
  group.w.free <- lavmodel@group.w.free
  # fixed.x <- lavmodel@fixed.x
  conditional.x <- lavmodel@conditional.x
  num.idx <- lavmodel@num.idx
  th.idx <- lavmodel@th.idx
  estimator.args <- lavmodel@estimator.args

  # do we need WLS.est?
  if (estimator %in% c("ULS", "WLS", "DWLS", "NTRLS", "DLS")) {
    lavimplied <- lav_model_implied(lavmodel, GLIST = GLIST)
    # check for COV with negative diagonal elements?
    for (g in 1:lavsamplestats@ngroups) {
      COV <- if (lavmodel@conditional.x) {
        lavimplied$res.cov[[g]]
      } else {
        lavimplied$cov[[g]]
      }
      dCOV <- diag(COV)
      if (anyNA(COV) || any(dCOV < 0)) {
        # return NA
        fx <- as.numeric(NA)
        attr(fx, "fx.group") <- rep(as.numeric(NA), lavsamplestats@ngroups)
        return(fx)
      }
    }
    WLS.est <- lav_model_wls_est(
      lavmodel = lavmodel, GLIST = GLIST,
      lavimplied = lavimplied
    ) # ,
    # cov.x = lavsamplestats@cov.x)
    if (estimator == "NTRLS") {
      Sigma.hat <- lav_model_sigma(
        lavmodel = lavmodel, GLIST = GLIST,
        extra = TRUE
      )
      Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST = GLIST)
    }
    if (estimator == "DLS" && estimator.args$dls.GammaNT == "model") {
      Sigma.hat <- lav_model_sigma(
        lavmodel = lavmodel, GLIST = GLIST,
        extra = FALSE
      )
      Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST = GLIST)
    }
    if (lav_debug()) print(WLS.est)
  } else if (estimator %in% c("ML", "GLS", "PML", "FML", "REML", "catML") &&
    lavdata@nlevels == 1L) {
    # compute moments for all groups
    # if(conditional.x) {
    #    Sigma.hat <- lav_model_cond2joint_sigma(lavmodel = lavmodel,
    #                     GLIST = GLIST, lavsamplestats = lavsamplestats,
    #                     extra = (estimator %in% c("ML", "REML","NTRLS")))
    # } else {
    Sigma.hat <- lav_model_sigma(
      lavmodel = lavmodel, GLIST = GLIST,
      extra = (estimator %in% c(
        "ML", "REML",
        "NTRLS", "catML"
      ))
    )
    # }

    # if (estimator == "REML") {
    #   LAMBDA <- lav_model_lambda(lavmodel = lavmodel, GLIST = GLIST)
    # }

    # ridge?
    if (lavsamplestats@ridge > 0.0) {
      for (g in 1:lavsamplestats@ngroups) {
        diag(Sigma.hat[[g]]) <- diag(Sigma.hat[[g]]) +
          lavsamplestats@ridge
      }
    }
    if (lav_debug()) print(Sigma.hat)

    if (meanstructure) {
      # if(conditional.x) {
      #    Mu.hat <- lav_model_cond2joint_mu(lavmodel = lavmodel, GLIST = GLIST,
      #                           lavsamplestats = lavsamplestats)
      # } else {
      Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST = GLIST)
      # }
    }

    if (categorical) {
      TH <- lav_model_th(lavmodel = lavmodel, GLIST = GLIST)
    }

    if (conditional.x) {
      PI <- lav_model_pi(lavmodel = lavmodel, GLIST = GLIST)
    }

    if (group.w.free) {
      GW <- lav_model_gw(lavmodel = lavmodel, GLIST = GLIST)
    }
  } else if (estimator == "MML") {
    TH <- lav_model_th(lavmodel = lavmodel, GLIST = GLIST)
    THETA <- lav_model_theta(lavmodel = lavmodel, GLIST = GLIST)
    GW <- lav_model_gw(lavmodel = lavmodel, GLIST = GLIST)
  }

  fx <- 0.0
  fx.group <- numeric(lavsamplestats@ngroups)
  logl.group <- rep(as.numeric(NA), lavsamplestats@ngroups)

  for (g in 1:lavsamplestats@ngroups) {
    # incomplete data and fiml?
    if (lavsamplestats@missing.flag && estimator != "Bayes") {
      if (estimator == "ML" && lavdata@nlevels == 1L) {
        # FIML
        if (!attr(Sigma.hat[[g]], "po")) {
          fx <- as.numeric(Inf)
          attr(fx, "fx.group") <- rep(as.numeric(Inf), lavsamplestats@ngroups)
          return(fx)
        }
        # check if h1 is defined (eg zero coverage)
        if (is.null(lavsamplestats@missing.h1[[g]]$h1)) {
          #this.h1 <- lav_mvnorm_missing_loglik_samplestats(
          #  Yp = lavsamplestats@missing[[g]],
          #  Mu = Mu.hat[[g]], Sigma = Sigma.hat[[g]],
          #  log2pi = FALSE, minus.two = TRUE) / lavsamplestats@nobs[[g]]
          #this.h1 <- this.h1 * 0.9999999 # avoid perfect fit
          this.h1 <- NULL #for now
        } else {
          this.h1 <- lavsamplestats@missing.h1[[g]]$h1
        }
        group.fx <- lav_model_objective_fiml(
          Sigma.hat = Sigma.hat[[g]],
          Mu.hat = Mu.hat[[g]],
          Yp = lavsamplestats@missing[[g]],
          h1 = this.h1, N = lavsamplestats@nobs[[g]]
        )
      } else if (estimator == "ML" && lavdata@nlevels > 1L) {
        # FIML twolevel
        group.fx <- lav_model_objective_2l(
          lavmodel = lavmodel,
          GLIST = GLIST,
          Y1 = lavdata@X[[g]],
          Lp = lavdata@Lp[[g]],
          Mp = lavdata@Mp[[g]],
          lavsamplestats = lavsamplestats,
          group = g
        )
      } else {
        lav_msg_stop(gettextf(
          "this estimator: `%s' can not be used with incomplete data and
          the missing=\"ml\" option", estimator))
      }
    } else if (estimator == "ML" || estimator == "Bayes" ||
      estimator == "catML") {
      # complete data
      # ML and friends
      if (lavdata@nlevels > 1L) {
        if (estimator %in% c("catML", "Bayes")) {
          lav_msg_stop(gettext("multilevel data not supported for estimator"),
                       estimator)
          }
        group.fx <- lav_model_objective_2l(
          lavmodel = lavmodel,
          GLIST = GLIST,
          Lp = lavdata@Lp[[g]],
          Mp = NULL, # complete data
          lavsamplestats = lavsamplestats,
          group = g
        )
      } else if (conditional.x) {
        group.fx <- lav_model_objective_ml_res(
          Sigma.hat        = Sigma.hat[[g]],
          Mu.hat           = Mu.hat[[g]],
          PI               = PI[[g]],
          res.cov          = lavsamplestats@res.cov[[g]],
          res.int          = lavsamplestats@res.int[[g]],
          res.slopes       = lavsamplestats@res.slopes[[g]],
          res.cov.log.det  = lavsamplestats@res.cov.log.det[[g]],
          cov.x            = lavsamplestats@cov.x[[g]],
          mean.x           = lavsamplestats@mean.x[[g]]
        )
      } else {
        group.fx <- lav_model_objective_ml(
          Sigma.hat        = Sigma.hat[[g]],
          Mu.hat           = Mu.hat[[g]],
          data.cov         = lavsamplestats@cov[[g]],
          data.mean        = lavsamplestats@mean[[g]],
          data.cov.log.det = lavsamplestats@cov.log.det[[g]],
          meanstructure    = meanstructure
        )
      }


      ### GLS #### (0.6-10: not using WLS function any longer)
    } else if (estimator == "GLS") {
      group.fx <- lav_model_objective_gls(
        Sigma.hat        = Sigma.hat[[g]],
        Mu.hat           = Mu.hat[[g]],
        data.cov         = lavsamplestats@cov[[g]],
        data.cov.inv     = lavsamplestats@icov[[g]],
        data.mean        = lavsamplestats@mean[[g]],
        meanstructure    = meanstructure,
		correlation      = correlation
      )
    } else if (estimator == "WLS" ||
      estimator == "DLS" ||
      estimator == "NTRLS") {
      # full weight matrix
      if (estimator == "WLS") {
        WLS.V <- lavsamplestats@WLS.V[[g]]
      } else if (estimator == "DLS") {
        if (estimator.args$dls.GammaNT == "sample") {
          WLS.V <- lavsamplestats@WLS.V[[g]]
        } else {
          dls.a <- estimator.args$dls.a
          GammaNT <- lav_samplestats_Gamma_NT(
            COV            = Sigma.hat[[g]],
            MEAN           = Mu.hat[[g]],
            rescale        = FALSE,
            x.idx          = lavsamplestats@x.idx[[g]],
            fixed.x        = lavmodel@fixed.x,
            conditional.x  = lavmodel@conditional.x,
            meanstructure  = lavmodel@meanstructure,
            slopestructure = lavmodel@conditional.x
          )
          W.DLS <- (1 - dls.a) * lavsamplestats@NACOV[[g]] + dls.a * GammaNT
          WLS.V <- lav_matrix_symmetric_inverse(W.DLS)
        }
      } else if (estimator == "NTRLS") {
        # WLS.V <- lav_samplestats_Gamma_inverse_NT(
        #             ICOV = attr(Sigma.hat[[g]],"inv")[,,drop=FALSE],
        #             COV            = Sigma.hat[[g]][,,drop=FALSE],
        #             MEAN           = Mu.hat[[g]],
        #             x.idx          = c(10000,10001), ### FIXME!!!!
        #             fixed.x        = fixed.x,
        #             conditional.x  = conditional.x,
        #             meanstructure  = meanstructure,
        #             slopestructure = conditional.x)
        WLS.V <- lav_mvnorm_information_expected(
          Sigma = Sigma.hat[[g]],
          x.idx = lavsamplestats@x.idx[[g]],
          meanstructure = lavmodel@meanstructure
        )
        # DEBUG!!!!
        # WLS.V <- 2*WLS.V
      }

      group.fx <- lav_model_objective_wls(
        WLS.est = WLS.est[[g]],
        WLS.obs = lavsamplestats@WLS.obs[[g]],
        WLS.V = WLS.V
      )
      attr(group.fx, "WLS.est") <- WLS.est[[g]]
    } else if (estimator == "DWLS" || estimator == "ULS") {
      # diagonal weight matrix
      group.fx <- lav_model_objective_dwls(
        WLS.est = WLS.est[[g]],
        WLS.obs = lavsamplestats@WLS.obs[[g]],
        WLS.VD = lavsamplestats@WLS.VD[[g]]
      )
      attr(group.fx, "WLS.est") <- WLS.est[[g]]
    } else if (estimator == "PML") {
      # Pairwise maximum likelihood
      if (lavdata@nlevels > 1L) {
        # group.fx <- lav_model_objective_pml.2L(lavmodel       = lavmodel,
        #                             GLIST          = GLIST,
        #                             Lp             = lavdata@Lp[[g]],
        #                             lavsamplestats = lavsamplestats,
        #                             group          = g)
        group.fx <- 0 # for now
        attr(group.fx, "logl") <- 0
      } else if (conditional.x) {
        group.fx <- lav_model_objective_pml(
          Sigma.hat = Sigma.hat[[g]],
          Mu.hat = Mu.hat[[g]],
          TH = TH[[g]],
          PI = PI[[g]],
          th.idx = th.idx[[g]],
          num.idx = num.idx[[g]],
          X = lavdata@X[[g]],
          eXo = lavdata@eXo[[g]],
          wt = lavdata@weights[[g]],
          lavcache = lavcache[[g]],
          missing = lavdata@missing
        )
      } else {
        group.fx <- lav_model_objective_pml(
          Sigma.hat = Sigma.hat[[g]],
          Mu.hat = Mu.hat[[g]],
          TH = TH[[g]],
          PI = NULL,
          th.idx = th.idx[[g]],
          num.idx = num.idx[[g]],
          X = lavdata@X[[g]],
          eXo = NULL,
          wt = lavdata@weights[[g]],
          lavcache = lavcache[[g]],
          missing = lavdata@missing
        )
      }
      logl.group[g] <- attr(group.fx, "logl")
    } else if (estimator == "FML") {
      # Full maximum likelihood (underlying multivariate normal)
      group.fx <- lav_model_objective_fml(
        Sigma.hat = Sigma.hat[[g]],
        TH = TH[[g]],
        th.idx = th.idx[[g]],
        num.idx = num.idx[[g]],
        X = lavdata@X[[g]],
        lavcache = lavcache[[g]]
      )
    } else if (estimator == "MML") {
      # marginal maximum likelihood
      group.fx <- lav_model_objective_mml(
        lavmodel = lavmodel,
        GLIST = GLIST,
        THETA = THETA[[g]],
        TH = TH[[g]],
        group = g,
        lavdata = lavdata,
        sample.mean = lavsamplestats@mean[[g]],
        sample.mean.x = lavsamplestats@mean.x[[g]],
        lavcache = lavcache
      )
    } else if (estimator == "REML") {
      # restricted/residual maximum likelihood
      group.fx <- lav_model_objective_reml(
        Sigma.hat = Sigma.hat[[g]],
        Mu.hat = Mu.hat[[g]],
        data.cov = lavsamplestats@cov[[g]],
        data.mean = lavsamplestats@mean[[g]],
        data.cov.log.det = lavsamplestats@cov.log.det[[g]],
        meanstructure = meanstructure,
        group = g,
        lavmodel = lavmodel,
        lavsamplestats = lavsamplestats,
        lavdata = lavdata
      )
    } else {
      lav_msg_stop(gettext("unsupported estimator:"), estimator)
    }

    if (estimator %in% c("ML", "REML", "NTRLS", "catML")) {
      if (lavdata@nlevels == 1L) {
        group.fx <- 0.5 * group.fx ## FIXME
      }
    } else if (estimator == "PML" || estimator == "FML" ||
      estimator == "MML") {
      # do nothing
    } else if (estimator == "DLS") {
      if (estimator.args$dls.FtimesNminus1) {
        group.fx <- 0.5 * (lavsamplestats@nobs[[g]] - 1) / lavsamplestats@nobs[[g]] * group.fx
      } else {
        group.fx <- 0.5 * group.fx
      }
    } else {
      group.fx <- 0.5 * (lavsamplestats@nobs[[g]] - 1) / lavsamplestats@nobs[[g]] * group.fx
    }

    fx.group[g] <- group.fx
  } # g

  if (lavsamplestats@ngroups > 1) {
    ## FIXME: if group.w.free, should we use group.w or nobs???
    ##  - if we use estimated group.w, gradient changes!!!!
    ##  - but, if group models are misspecified, the group weights
    ##    will be affected too... which is unwanted (I think)
    # if(group.w.free) {
    # nobs <- unlist(GW) * lavsamplestats@ntotal
    #   nobs <- exp(unlist(GW))
    # } else {
    if (estimator == "PML") {
      # no weighting needed! (since N_g is part of the logl per group)
      fx <- sum(fx.group)
	} else if(lavdata@nlevels > 1L) {
	  # no weighting needed! (implicit in obj, which is based on loglik)
	  fx <- sum(fx.group)
    } else {
      nobs <- unlist(lavsamplestats@nobs)
      # }
      fx <- weighted.mean(fx.group, w = nobs)
    }
  } else { # single group
    fx <- fx.group[1]
  }

  # penalty for group.w + ML
  if (group.w.free && estimator %in% c(
    "ML", "MML", "FML", "PML",
    "REML", "catML"
  )) {
    # obs.prop <- unlist(lavsamplestats@group.w)
    # est.prop <- unlist(GW)
    # if(estimator %in% c("WLS", "GLS", ...) {
    #    # X2 style discrepancy measures (aka GLS/WLS!!)
    #    fx.w <- sum ( (obs.prop-est.prop)^2/est.prop )
    # } else {
    #    # G2 style discrepancy measures (aka ML)
    #    # deriv is here -2 * (obs.prop - est.prop)
    # fx.w <- sum(obs.prop * log(obs.prop/est.prop) )
    # }

    # poisson kernel
    obs.freq <- unlist(lavsamplestats@group.w) * lavsamplestats@ntotal
    est.freq <- exp(unlist(GW))
    fx.w <- -1 * sum(obs.freq * log(est.freq) - est.freq)
    # divide by N (to be consistent with the rest of lavaan)
    fx.w <- fx.w / lavsamplestats@ntotal

    fx.sat <- sum(obs.freq * log(obs.freq) - obs.freq)
    fx.sat <- fx.sat / lavsamplestats@ntotal

    # saturated - poisson
    # fx.w <- sum(obs.freq * log(obs.freq/est.freq))
    # does not work without constraints? --> need lagrange multiplier

    fx <- fx + (fx.w + fx.sat)
  }

  fx.value <- as.numeric(fx)

  attr(fx, "fx.group") <- fx.group
  if (estimator == "PML") {
    attr(fx, "logl.group") <- logl.group
    attr(fx, "fx.pml") <- fx.value
  }

  fx
}

# create (if not already created) an environment to put cached objects in
# this is executed when the package is 'compiled' !
if (!exists("lavaan_cache_env")) lavaan_cache_env <- new.env(parent = emptyenv())

# tracing possibility in functions defined below, an example of use :
#
# in the function where you want to trace add a line
#     lav_trace(x)
# where x is a characterstring you want to show in the trace
#
# thereafter execute a script like this:
# library(lavaan)
# lavaan:::lav_trace_set(TRUE)
# model <- '
# # latent variable definitions
#    ind60 =~ x1 + x2 + x3
#    dem60 =~ y1 + a*y2 + b*y3 + c*y4
#    dem65 =~ y5 + a*y6 + b*y7 + c*y8
#
# # regressions
#   dem60 ~ ind60
#   dem65 ~ ind60 + dem60
#
# # residual correlations
#   y1 ~~ y5
#   y2 ~~ y4 + y6
#   y3 ~~ y7
#   y4 ~~ y8
#   y6 ~~ y8
# '
# fit <- sem(model, data = PoliticalDemocracy)
# summary(fit)
# lavaan:::lav_trace_set(FALSE)
# lavaan:::lav_trace_print("PolDem_trace.txt")
#

lav_trace <- function(content = "") {
  ignore.in.stack <- c(
    "eval", "try", "tryCatch", "tryCatchList", "tryCatchOne", "doTryCatch",
    "which", "unique", "as.list", "as.character", "unlist", "lav_trace",
    "source", "withVisible", "tryCatch.W.E", "withCallingHandlers", "do.call"
  )
  if (!exists("TRACE", lavaan_cache_env)) {
    return(invisible(NULL))
  }
  if (!exists("TRACENR", lavaan_cache_env)) assign("TRACENR", 1L, lavaan_cache_env)
  tracenr <- get("TRACENR", lavaan_cache_env)
  x <- sub("[() ].*$", "", as.character(sys.calls()))
  if (length(x) == 0) {
    return(invisible(NULL))
  }
  a <- paste0("trc", formatC(tracenr, format = "d", width = 5, flag = "0"))
  x <- x[!(x %in% ignore.in.stack)]
  if (length(x) > 0) {
    assign(a, list(stack = x, content = content, time = Sys.time()), lavaan_cache_env)
    assign("TRACENR", tracenr + 1L, lavaan_cache_env)
  }

  invisible(NULL)
}

lav_trace_set <- function(state = NULL, silent = FALSE) {
  traceon <- exists("TRACE", lavaan_cache_env)
  msg <- ""
  if (is.null(state)) {
    rm(list = ls(lavaan_cache_env, pattern = "^trc"), envir = lavaan_cache_env)
    if (exists("TRACENR", lavaan_cache_env)) rm("TRACENR", envir = lavaan_cache_env)
    msg <- "Traces removed."
  } else if (state) {
    if (traceon) {
      msg <- "Trace already active!"
    } else {
      assign("TRACE", TRUE, lavaan_cache_env)
      msg <- "Trace on."
    }
  } else {
    if (traceon) {
      rm("TRACE", envir = lavaan_cache_env)
      msg <- "Trace off."
    } else {
      msg <- "Trace not active!"
    }
  }
  if (!silent) cat(msg, "\n", sep = "")

  invisible(NULL)
}

lav_trace_get <- function() {
  traceobjects <- ls(lavaan_cache_env, pattern = "^trc")
  if (length(traceobjects) == 0) {
    return(list())
  }
  x <- mget(traceobjects, envir = lavaan_cache_env)
  x <- x[order(names(x))]

  x
}

lav_trace_print <- function(file = "", clean_after = (file != "")) {
  cat("Trace print on ", format(Sys.time(), format = "%F"), "\n\n", file = file)
  x <- lav_trace_get()
  for (x1 in x) {
    cat(format(x1$time, format = "%T"),
      paste(x1$stack, collapse = ">"), ":", x1$content,
      "\n",
      sep = " ", file = file, append = TRUE
    )
  }
  if (clean_after) lav_trace_set(NULL, TRUE)
}

lav_trace_summary <- function(file = "", clean_after = FALSE) {
  x <- lav_trace_get()
  temp <- new.env(parent = emptyenv())
  for (x1 in x) {
    nn <- length(x1$stack)
    mm <- paste(x1$stack[nn], paste(x1$stack[seq_len(nn - 1L)], collapse = ">"), sep = "\t")
    assign(mm, 1L + get0(mm, temp, ifnotfound = 0L), temp)
  }
  objects <- sort(ls(temp))
  for (i in seq_along(objects)) {
    cat(objects[i], get(objects[i], temp), "\n", file = file, append = TRUE)
  }
  if (clean_after) lav_trace_set(NULL, TRUE)
}

# generate labels for each parameter
lav_partable_labels <- function(partable,
                                blocks = c("group", "level"),
                                group.equal = "", group.partial = "",
                                type = "user") {
  # catch empty partable
  if (length(partable$lhs) == 0L) {
    return(character(0L))
  }

  # default labels
  label <- paste(partable$lhs, partable$op, partable$rhs, sep = "")

  # handle multiple groups
  if ("group" %in% blocks) {
    if (is.character(partable$group)) {
      group.label <- unique(partable$group)
      group.label <- group.label[nchar(group.label) > 0L]
      ngroups <- length(group.label)
    } else {
      ngroups <- lav_partable_ngroups(partable)
      group.label <- 1:ngroups
    }
    if (ngroups > 1L) {
      for (g in 2:ngroups) {
        label[partable$group == group.label[g]] <-
          paste(label[partable$group == group.label[g]],
            ".g", g,
            sep = ""
          )
      }
    }
  } else {
    ngroups <- 1L
  }

  # cat("DEBUG: label start:\n"); print(label); cat("\n")
  # cat("group.equal = ", group.equal, "\n")
  # cat("group.partial = ", group.partial, "\n")

  # use group.equal so that equal sets of parameters get the same label
  if (ngroups > 1L && length(group.equal) > 0L) {
    if ("intercepts" %in% group.equal ||
      "residuals" %in% group.equal ||
      "residual.covariances" %in% group.equal) {
      ov.names.nox <- vector("list", length = ngroups)
      for (g in 1:ngroups) {
        ov.names.nox[[g]] <- unique(unlist(lav_partable_vnames(partable, "ov.nox", group = g)))
      }
    }
    if ("thresholds" %in% group.equal) {
      ov.names.ord <- vector("list", length = ngroups)
      for (g in 1:ngroups) {
        ov.names.ord[[g]] <- unique(unlist(lav_partable_vnames(partable, "ov.ord", group = g)))
      }
    }
    if ("means" %in% group.equal ||
      "lv.variances" %in% group.equal ||
      "lv.covariances" %in% group.equal) {
      lv.names <- vector("list", length = ngroups)
      for (g in 1:ngroups) {
        lv.names[[g]] <- unique(unlist(lav_partable_vnames(partable, "lv", group = g)))
      }
    }

    # g1.flag: TRUE if included, FALSE if not
    g1.flag <- logical(length(partable$lhs))

    # LOADINGS
    if ("loadings" %in% group.equal) {
      g1.flag[partable$op == "=~" & partable$group == 1L] <- TRUE
    }
    # COMPOSITE LOADINGS (new in 0.6-4)
    if ("composite.loadings" %in% group.equal) {
      # new setting (0.6-20): <~
      if (any(partable$op == "<~" & partable$group == 1L)) {
        lav_msg_warn(gettext("composite.loadings are in fact composite weights;
                              better use composite.weights"))
        g1.flag[partable$op == "<~" & partable$group == 1L] <- TRUE
      } else {
        # old school: composites are phantom constructs with zero residual...
        lv.f.names <- unique(unlist(lav_partable_vnames(partable, "lv.formative")))
        g1.flag[partable$op == "~" &
                partable$lhs %in% lv.f.names &
                partable$group == 1L] <- TRUE
      }
    }
    # COMPOSITE WEIGHTS (new in 0.6-20) # same as 'loadings'...
    if ("composite.weights" %in% group.equal) {
      g1.flag[partable$op == "<~" & partable$group == 1L] <- TRUE
    }
    # INTERCEPTS (OV)
    if ("intercepts" %in% group.equal) {
      g1.flag[partable$op == "~1" & partable$group == 1L &
        partable$lhs %in% ov.names.nox[[1L]]] <- TRUE
    }
    # THRESHOLDS (OV-ORD)
    if ("thresholds" %in% group.equal) {
      g1.flag[partable$op == "|" & partable$group == 1L &
        partable$lhs %in% ov.names.ord[[1L]]] <- TRUE
    }
    # MEANS (LV)
    if ("means" %in% group.equal) {
      g1.flag[partable$op == "~1" & partable$group == 1L &
        partable$lhs %in% lv.names[[1L]]] <- TRUE
    }
    # REGRESSIONS
    if ("regressions" %in% group.equal) {
      g1.flag[partable$op == "~" & partable$group == 1L] <- TRUE
    }
    # RESIDUAL variances (FIXME: OV ONLY!)
    if ("residuals" %in% group.equal) {
      g1.flag[partable$op == "~~" & partable$group == 1L &
        partable$lhs %in% ov.names.nox[[1L]] &
        partable$lhs == partable$rhs] <- TRUE
    }
    # RESIDUAL covariances (FIXME: OV ONLY!)
    if ("residual.covariances" %in% group.equal) {
      g1.flag[partable$op == "~~" & partable$group == 1L &
        partable$lhs %in% ov.names.nox[[1L]] &
        partable$lhs != partable$rhs] <- TRUE
    }
    # LV VARIANCES
    if ("lv.variances" %in% group.equal) {
      g1.flag[partable$op == "~~" & partable$group == 1L &
        partable$lhs %in% lv.names[[1L]] &
        partable$lhs == partable$rhs] <- TRUE
    }
    # LV COVARIANCES
    if ("lv.covariances" %in% group.equal) {
      g1.flag[partable$op == "~~" & partable$group == 1L &
        partable$lhs %in% lv.names[[1L]] &
        partable$lhs != partable$rhs] <- TRUE
    }

    # if group.partial, set corresponding flag to FALSE
    if (length(group.partial) > 0L) {
      g1.flag[label %in% group.partial &
        partable$group == 1L] <- FALSE
    }

    # for each (constrained) parameter in 'group 1', find a similar one
    # in the other groups (we assume here that the models need
    # NOT be the same across groups!
    g1.idx <- which(g1.flag)
    for (i in 1:length(g1.idx)) {
      ref.idx <- g1.idx[i]
      idx <- which(partable$lhs == partable$lhs[ref.idx] &
        partable$op == partable$op[ref.idx] &
        partable$rhs == partable$rhs[ref.idx] &
        partable$group > 1L)
      label[idx] <- label[ref.idx]
    }
  }

  # cat("DEBUG: g1.idx = ", g1.idx, "\n")
  # cat("DEBUG: label after group.equal:\n"); print(label); cat("\n")

  # handle other block identifier (not 'group')
  for (block in blocks) {
    if (block == "group") {
      next
    } else if (block == "level" && !is.null(partable[[block]])) {
      # all but first level
      lev_vals <- lav_partable_level_values(partable)
      idx <- which(partable[[block]] != lev_vals[1])
      label[idx] <- paste(label[idx], ".", "l",
        partable[[block]][idx],
        sep = ""
      )
    } else if (!is.null(partable[[block]])) {
      label <- paste(label, ".", block, partable[[block]], sep = "")
    }
  }

  # user-specified labels -- override everything!!
  user.idx <- which(nchar(partable$label) > 0L)
  label[user.idx] <- partable$label[user.idx]

  # cat("DEBUG: user.idx = ", user.idx, "\n")
  # cat("DEBUG: label after user.idx:\n"); print(label); cat("\n")

  # which labels do we need?
  if (type == "user") {
    idx <- 1:length(label)
  } else if (type == "free") {
    # idx <- which(partable$free > 0L & !duplicated(partable$free))
    idx <- which(partable$free > 0L)
    # } else if(type == "unco") {
    #    idx <- which(partable$unco > 0L & !duplicated(partable$unco))
  } else {
    lav_msg_stop(gettext("argument `type' must be one of free or user"))
  }

  label[idx]
}

# Browne's residual test statistic
# see Browne (1984) eq 2.20a

# T_B = (N-1) * t(RES) %*% Delta.c %*%
#                          solve(t(Delta.c) %*% Gamma %*% Delta.c) %*%
#                          t(Delta.c) %*% RES
#
#     = (N-1) * t(RES) %*% (Gamma.inv -
#                           Gamma.inv %*% Delta %*%
#                                  solve(t(Delta) %*% Gamma.inv %*% Delta) %*%
#                           t(Delta) %*% Gamma.inv) %*% RES

# Note: if Gamma == solve(Weight matrix), then:
# t(Delta) %*% solve(Gamma) %*% RES == 0-vector!
#
# Therefore:
# - if estimator = "WLS", X2 == Browne's residual ADF statistic
# - if estimator = "GLS", X2 == Browne's residual NT statistic
#
# - if estimator = "NTRLS", X2 == Browne's residual NT statistic (model-based)
#   also known as the RLS test statistic
#   ... except in multigroup + equality constraints, where
#   t(Delta) %*% solve(Gamma) %*% RES not zero everywhere!?

# YR 26 July 2022: add alternative slots, if lavobject = NULL
# YR 22 Jan  2023: allow for model-based 'structured' Sigma

# TODo: - allow for non-linear equality constraints
#         (see Browne, 1982, eq 1.7.19; although we may face singular matrices)

lav_test_browne <- function(lavobject = NULL,
                            # or
                            lavdata = NULL,
                            lavsamplestats = NULL, # WLS.obs, NACOV
                            lavmodel = NULL,
                            lavpartable = NULL, # DF
                            lavoptions = NULL,
                            lavh1 = NULL,
                            lavimplied = NULL,
                            # further options:
                            n.minus.one = "default",
                            ADF = TRUE,
                            model.based = FALSE) {
  if (!is.null(lavobject)) {
    # check input
    if (!inherits(lavobject, "lavaan")) {
      lav_msg_stop(gettext("object is not a lavaan object."))
    }

    # slots
    lavdata <- lavobject@Data
    lavsamplestats <- lavobject@SampleStats
    lavmodel <- lavobject@Model
    lavpartable <- lavobject@ParTable
    lavoptions <- lavobject@Options
    lavh1 <- lavobject@h1
    lavimplied <- lavobject@implied
  }

  if (!ADF && lavmodel@categorical) {
    lav_msg_stop(gettext("normal theory version not available in the categorical
                         setting."))
  }
  if (lavdata@missing != "listwise" && !model.based) {
    lav_msg_stop(gettext("Browne's test is not available when data is missing"))
  }
  if (lavdata@nlevels > 1L) {
    lav_msg_stop(gettext("Browne's test is not available when data is
                         multilevel."))
  }
  if (length(lavmodel@ceq.nonlinear.idx) > 0L) {
    lav_msg_stop(gettext("Browne's test is not available (yet) when nonlinear
                         equality constraints are involved."))
  }

  if (!is.logical(n.minus.one)) {
    if (lavoptions$estimator == "ML" &&
      lavoptions$likelihood == "normal") {
      n.minus.one <- FALSE
    } else {
      n.minus.one <- TRUE
    }
  }

  # ingredients
  Delta <- lav_model_delta(lavmodel)
  if (ADF) {
    # ADF version
    if (!is.null(lavsamplestats@NACOV[[1]])) {
      Gamma <- lavsamplestats@NACOV
    } else {
      if (!is.null(lavobject)) {
        if (lavobject@Data@data.type != "full") {
          lav_msg_stop(gettext("ADF version not available without full data or
                               user-provided Gamma/NACOV matrix"))
        }
        Gamma <- lav_object_gamma(lavobject,
          ADF = TRUE,
          model.based = model.based
        )
      } else {
        if (lavdata@data.type != "full") {
          lav_msg_stop(gettext("ADF version not available without full data or
                               user-provided Gamma/NACOV matrix"))
        }
        Gamma <- lav_object_gamma(
          lavobject = NULL,
          lavdata = lavdata,
          lavoptions = lavoptions,
          lavsamplestats = lavsamplestats,
          lavh1 = lavh1,
          lavimplied = lavimplied,
          ADF = TRUE,
          model.based = model.based
        )
      }
    }
  } else {
    # NT version
    if (!is.null(lavobject)) {
      Gamma <- lav_object_gamma(lavobject,
        ADF = FALSE,
        model.based = model.based
      )
    } else {
      Gamma <- lav_object_gamma(
        lavobject = NULL,
        lavdata = lavdata,
        lavoptions = lavoptions,
        lavsamplestats = lavsamplestats,
        lavh1 = lavh1,
        lavimplied = lavimplied,
        ADF = FALSE,
        model.based = model.based
      )
    }
  }
  WLS.obs <- lavsamplestats@WLS.obs
  WLS.est <- lav_model_wls_est(lavmodel)
  nobs <- lavsamplestats@nobs
  ntotal <- lavsamplestats@ntotal

  # linear equality constraints?
  lineq.flag <- FALSE
  if (lavmodel@eq.constraints) {
    lineq.flag <- TRUE
  } else if (lavmodel@ceq.simple.only) {
    lineq.flag <- TRUE
  }

  # compute T.B per group
  ngroups <- length(WLS.obs)
  stat.group <- numeric(ngroups)

  # 1. standard setting: no equality constraints
  if (!lineq.flag) {
    for (g in seq_len(ngroups)) {
      RES <- WLS.obs[[g]] - WLS.est[[g]]
      Delta.g <- Delta[[g]]
      Delta.c <- lav_matrix_orthogonal_complement(Delta.g)
      tDGD <- crossprod(Delta.c, Gamma[[g]]) %*% Delta.c
      # if fixed.x = TRUE, Gamma[[g]] may contain zero col/rows
      tDGD.inv <- lav_matrix_symmetric_inverse(tDGD)
      if (n.minus.one) {
        Ng <- nobs[[g]] - 1L
      } else {
        Ng <- nobs[[g]]
      }
      tResDelta.c <- crossprod(RES, Delta.c)
      stat.group[g] <-
        Ng * drop(tResDelta.c %*% tDGD.inv %*% t(tResDelta.c))
    }
    STAT <- sum(stat.group)

    # 2. linear equality constraint
  } else if (lineq.flag) {
    RES.all <- do.call("c", WLS.obs) - do.call("c", WLS.est)
    Delta.all <- do.call("rbind", Delta)
    if (lavmodel@eq.constraints) {
      Delta.g <- Delta.all %*% lavmodel@eq.constraints.K
    } else if (lavmodel@ceq.simple.only) {
      Delta.g <- Delta.all %*% lavmodel@ceq.simple.K
    }
    Gamma.inv.weighted <- vector("list", ngroups)
    for (g in seq_len(ngroups)) {
      if (n.minus.one) {
        Ng <- nobs[[g]] - 1L
      } else {
        Ng <- nobs[[g]]
      }
      Gamma.inv.temp <- try(solve(Gamma[[g]]), silent = TRUE)
      if (inherits(Gamma.inv.temp, "try-error")) {
        # TDJ: This will happen whenever an (otherwise) unrestricted
        #      covariance matrix has a structure to it, such as equal
        #      variances (and certain covariances) for 2 members of an
        #      indistinguishable dyad (represented as 2 columns).  In
        #      such cases, their (N)ACOV elements are also identical.
        Gamma.inv.temp <- MASS::ginv(Gamma[[g]])
      }
      Gamma.inv.weighted[[g]] <- Gamma.inv.temp * Ng / ntotal
    }
    GI <- lav_matrix_bdiag(Gamma.inv.weighted)
    tDGiD <- t(Delta.g) %*% GI %*% Delta.g
    tDGiD.inv <- MASS::ginv(tDGiD) # GI may be rank-deficient
    q1 <- drop(t(RES.all) %*% GI %*% RES.all)
    q2 <- drop(t(RES.all) %*%
      GI %*% Delta.g %*% tDGiD.inv %*% t(Delta.g) %*% GI %*%
      RES.all)
    STAT <- ntotal * (q1 - q2)
    stat.group <- STAT * unlist(nobs) / ntotal # proxy only

    # 3. nonlinear equality constraints
  } else {
    # TODO
  }


  # DF
  if (!is.null(lavobject)) {
    DF <- lavobject@test[[1]]$df
  } else {
    # same approach as in lav_test.R
    df <- lav_partable_df(lavpartable)
    if (nrow(lavmodel@con.jac) > 0L) {
      ceq.idx <- attr(lavmodel@con.jac, "ceq.idx")
      if (length(ceq.idx) > 0L) {
        neq <- qr(lavmodel@con.jac[ceq.idx, , drop = FALSE])$rank
        df <- df + neq
      }
    } else if (lavmodel@ceq.simple.only) {
      # needed??
      ndat <- lav_partable_ndat(lavpartable)
      npar <- max(lavpartable$free)
      df <- ndat - npar
    }
    DF <- df
  }

  if (ADF) {
    if (model.based) {
      # using model-based Gamma
      NAME <- "browne.residual.adf.model"
      LABEL <- "Browne's residual (ADF model-based) test"
    } else {
      # regular one
      NAME <- "browne.residual.adf"
      LABEL <- "Browne's residual-based (ADF) test"
    }
  } else {
    if (model.based) {
      # using model-implied Sigma (instead of S)
      # also called the 'reweighted least-squares (RLS)' version
      NAME <- "browne.residual.nt.model"
      LABEL <- "Browne's residual (NT model-based) test"
    } else {
      # regular one
      NAME <- "browne.residual.nt"
      LABEL <- "Browne's residual-based (NT) test"
    }
  }
  out <- list(
    test = NAME,
    stat = STAT,
    stat.group = stat.group,
    df = DF,
    refdistr = "chisq",
    pvalue = 1 - pchisq(STAT, DF),
    label = LABEL
  )
  out
}

# tools for the multivariate Bernoulli distribution
#
# see:
#
# Maydeu-Olivares & Joe (2005). Limited- and Full-Information Estimation and
# Goodness-of-Fit Testing in 2^n Contingency Tables: A Unified Framework.
# Journal of the American Statistical Association, 100, 1009--1020.

# YR. 15 April 2014 -- first version

# compute higher-order joint moments (Teugels 1991)
# PROP must be an array, with dim = rep(2L, nitems)
lav_tables_mvb_getPiDot <- function(PROP, order. = nitems) {
  # number of items/dimensions
  nitems <- length(dim(PROP))

  # compute 'pi dot' up to order = order.
  pidot <- unlist(
    lapply(1:order., function(Order) {
      IDX <- utils::combn(1:nitems, Order)
      tmp <- apply(IDX, 2L, function(idx) {
        as.numeric(apply(PROP, idx, sum))[1L]
      })
      tmp
    })
  )

  pidot
}

# compute 'T' matrix, so that pidot = T %*% prop
lav_tables_mvb_getT <- function(nitems = 3L, order. = nitems, rbind. = FALSE) {
  # index matrix
  INDEX <- array(1:(2^nitems), dim = rep(2L, nitems))

  T.r <- lapply(1:order., function(Order) {
    IDX <- utils::combn(1:nitems, Order)
    TT <- matrix(0L, ncol(IDX), 2^nitems)
    TT <- do.call(
      "rbind",
      lapply(1:ncol(IDX), function(i) {
        TRue <- as.list(rep(TRUE, nitems))
        TRue[IDX[, i]] <- 1L
        ARGS <- c(list(INDEX), TRue)
        T1 <- integer(2^nitems)
        T1[as.vector(do.call("[", ARGS))] <- 1L
        T1
      })
    )
    TT
  })

  if (rbind.) {
    T.r <- do.call("rbind", T.r)
  }

  T.r
}

# simple test function to check that  pidot = T %*% prop
lav_tables_mvb_test <- function(nitems = 3L) {
  freq <- sample(5:50, 2^nitems, replace = TRUE)
  prop <- freq / sum(freq)
  TABLE <- array(freq, dim = rep(2, nitems))
  PROP <- array(prop, dim = rep(2, nitems))
  # note: freq is always as.numeric(TABLE)
  #       prop is always as.numeric(PROP)

  pidot <- lav_tables_mvb_getPiDot(PROP)
  T.r <- lav_tables_mvb_getT(nitems = nitems, order. = nitems, rbind. = TRUE)

  if (lav_verbose()) {
    out <- cbind(as.numeric(T.r %*% prop), pidot)
    colnames(out) <- c("T * prop", "pidot")
    print(out)
  }

  all.equal(pidot, as.numeric(T.r %*% prop))
}

# L_r test of Maydeu-Olivares & Joe (2005) eq (4)
lav_tables_mvb_Lr <- function(nitems = 0L,
                              obs.prop = NULL, est.prop = NULL, nobs = 0L,
                              order. = 2L) {
  # recreate tables
  obs.PROP <- array(obs.prop, dim = rep(2L, nitems))
  est.PROP <- array(est.prop, dim = rep(2L, nitems))

  # compute {obs,est}.prop.dot
  obs.prop.dot <- lav_tables_mvb_getPiDot(obs.PROP, order. = order.)
  est.prop.dot <- lav_tables_mvb_getPiDot(est.PROP, order. = order.)

  # compute T.r
  T.r <- lav_tables_mvb_getT(nitems = nitems, order. = order., rbind. = TRUE)

  # compute GAMMA based on est.prop
  GAMMA <- diag(est.prop) - tcrossprod(est.prop)

  # compute XI
  XI <- T.r %*% GAMMA %*% t(T.r)

  # compute Lr
  diff.dot <- obs.prop.dot - est.prop.dot
  Lr <- as.numeric(nobs * t(diff.dot) %*% solve(XI) %*% diff.dot)
  df <- 2^nitems - 1L
  p.value <- 1 - pchisq(Lr, df = df)

  # return list
  list(Lr = Lr, df = df, p.value = p.value)
}

lav_lavaan_step17_lavaan <- function(lavmc = NULL,
                                     timing = NULL,
                                     lavoptions = NULL,
                                     lavpartable = NULL,
                                     lavdata = NULL,
                                     lavsamplestats = NULL,
                                     lavmodel = NULL,
                                     lavcache = NULL,
                                     lavfit = NULL,
                                     lavboot = NULL,
                                     lavoptim = NULL,
                                     lavimplied = NULL,
                                     lavloglik = NULL,
                                     lavvcov = NULL,
                                     lavtest = NULL,
                                     lavh1 = NULL,
                                     lavbaseline = NULL,
                                     laveqs = NULL,
                                     start.time0 = NULL) {
  # # # # # # # # # #
  # #  17. lavaan # #
  # # # # # # # # # #

  # stop timer
  # create lavaan object
  # if lavmodel@nefa > 0
  #   compute standardizedSolution and store in ParTable slot in lavaan object
  # if post-checking demanded and converged, execute
  #   lavInspect(lavaan, "post.check")
  #
  timing$total <- (proc.time()[3] - start.time0)
  timing$start.time <- NULL
  lavpta <- lav_partable_attributes(lavpartable)
  lavpartable <- lav_partable_remove_cache(lavpartable)
  lavaan <- new("lavaan", # type_of_slot - where created or modified ?
    # ------------   ------------------------- -
    version = packageDescription("lavaan", fields = "Version"),
    call = lavmc, # match.call - ldw_adapt_match_call
    timing = timing, # list - ldw_add_timing
    Options = lavoptions, # list - options (2) / data (3) / partable (4)
    ParTable = lavpartable,
    # list - partable/bounds/start/model/estoptim/vcovboot/rotation
    pta = lavpta, # list - lav_partable_attributes
    Data = lavdata, # S4 class - data (3)
    SampleStats = lavsamplestats, # S4 class - samplestats (5)
    Model = lavmodel, # S4 class - model (9) / estoptim (11) / vcovboot (13)
    Cache = lavcache, # list - cache (10)
    Fit = lavfit, # S4 class - lav_model_fit (14bis)
    boot = lavboot, # list - vcovboot (13)
    optim = lavoptim, # list - estoptim (11)
    implied = lavimplied, # list - lav_model_implied (12)
    loglik = lavloglik, # list - lav_model_loglik (12)
    vcov = lavvcov, # list - vcovboot (13)
    test = lavtest, # list - test (14)
    h1 = lavh1, # list - h1 (6)
    baseline = lavbaseline, # list - baseline (15)
    internal = list(), # empty list
    external = list() # empty list
  )

  # if model.type = "efa", add standardized solution to partable
  if (lavmodel@nefa > 0L) {
    if (lav_verbose()) {
      cat("computing standardized solution ... ")
    }
    std <- standardizedSolution(lavaan,
      remove.eq = FALSE,
      remove.ineq = FALSE, remove.def = FALSE
    )
    if (lav_verbose()) {
      cat(" done.\n")
    }
    lavaan@ParTable$est.std <- std$est.std
	if (!is.null(std$se)) {
      lavaan@ParTable$se.std <- std$se
    }
  }

  # eqs?
  if (length(laveqs) > 0L) {
    lavaan@internal <- list(eqs = laveqs)
  }

  # post-fitting check of parameters
  if (!is.null(lavoptions$check.post) && lavoptions$check.post &&
    lavTech(lavaan, "converged")) {
    if (lav_verbose()) {
      cat("post check  ...")
    }
    lavInspect(lavaan, "post.check")
    if (lav_verbose()) {
      cat(" done.\n")
    }
  }

  lavaan
}

# - 0.6-13: fix multiple-group UG^2 bug (reported by Gronneberg, Foldnes and
#           Moss) when Satterthwaite = TRUE, ngroups > 1, and eq constraints.
#
#           Note however that Satterthwaite = FALSE always (for now), so
#           the fix has no (visible) effect

lav_test_yuan_bentler <- function(lavobject = NULL,
                                  lavsamplestats = NULL,
                                  lavmodel = NULL,
                                  lavimplied = NULL,
                                  lavh1 = NULL,
                                  lavoptions = NULL,
                                  lavdata = NULL,
                                  TEST.unscaled = NULL,
                                  E.inv = NULL,
                                  B0.group = NULL,
                                  test = "yuan.bentler",
                                  mimic = "lavaan",
                                  # method          = "default",
                                  ug2.old.approach = FALSE,
                                  return.ugamma = FALSE) {
  TEST <- list()

  if (!is.null(lavobject)) {
    lavsamplestats <- lavobject@SampleStats
    lavmodel <- lavobject@Model
    lavoptions <- lavobject@Options
    lavpartable <- lavobject@ParTable
    lavimplied <- lavobject@implied
    lavh1 <- lavobject@h1
    lavdata <- lavobject@Data
    TEST$standard <- lavobject@test[[1]]
  } else {
    TEST$standard <- TEST.unscaled
  }

  # ug2.old.approach
  if (missing(ug2.old.approach)) {
    if (!is.null(lavoptions$ug2.old.approach)) {
      ug2.old.approach <- lavoptions$ug2.old.approach
    } else {
      ug2.old.approach <- FALSE
    }
  }

  # E.inv ok?
  if (length(lavoptions$information) == 1L &&
    length(lavoptions$h1.information) == 1L &&
    length(lavoptions$observed.information) == 1L) {
    E.inv.recompute <- FALSE
  } else if ((lavoptions$information[1] == lavoptions$information[2]) &&
    (lavoptions$h1.information[1] == lavoptions$h1.information[2]) &&
    (lavoptions$information[2] == "expected" ||
      lavoptions$observed.information[1] ==
        lavoptions$observed.information[2])) {
    E.inv.recompute <- FALSE
  } else {
    E.inv.recompute <- TRUE
    # change information options
    lavoptions$information[1] <- lavoptions$information[2]
    lavoptions$h1.information[1] <- lavoptions$h1.information[2]
    lavoptions$observed.information[1] <- lavoptions$observed.information[2]
  }
  if (!is.null(E.inv)) {
    E.inv.recompute <- FALSE # user-provided
  }

  # check test
  if (!all(test %in% c(
    "yuan.bentler",
    "yuan.bentler.mplus"
  ))) {
    lav_msg_warn(gettext("test must be one of `yuan.bentler', or
                         `yuan.bentler.mplus'; will use `yuan.bentler' only"))
    test <- "yuan.bentler"
  }

  # information
  information <- lavoptions$information[1]

  # ndat
  ndat <- numeric(lavsamplestats@ngroups)


  # do we have E.inv?
  if (is.null(E.inv) || E.inv.recompute) {
    E.inv <- try(
      lav_model_information(
        lavmodel = lavmodel,
        lavsamplestats = lavsamplestats,
        lavdata = lavdata,
        lavimplied = lavimplied,
        lavoptions = lavoptions,
        extra = FALSE,
        augmented = TRUE,
        inverted = TRUE
      ),
      silent = TRUE
    )
    if (inherits(E.inv, "try-error")) {
      if (return.ugamma) {
        lav_msg_warn(gettext(
          "could not invert information matrix needed for UGamma"))
        return(NULL)
      } else {
        TEST$standard$stat <- as.numeric(NA)
        TEST$standard$stat.group <- rep(as.numeric(NA), lavdata@ngroups)
        TEST$standard$pvalue <- as.numeric(NA)
        TEST[[test[1]]] <- c(TEST$standard,
          scaling.factor = as.numeric(NA),
          shift.parameter = as.numeric(NA),
          label = character(0)
        )
        lav_msg_warn(gettext("could not invert information [matrix needed for
                             robust test statistic"))
        TEST[[test[1]]]$test <- test[1] # to prevent lavTestLRT error when robust test is detected for some but not all models
        return(TEST)
      }
    }
  }

  # catch df == 0
  if (TEST$standard$df == 0L || TEST$standard$df < 0) {
    TEST[[test[1]]] <- c(TEST$standard,
      scaling.factor = as.numeric(NA),
      label = character(0)
    )
    TEST[[test[1]]]$test <- test[1] # to prevent lavTestLRT error when robust test is detected for some but not all models
    return(TEST)
  }

  # mean and variance adjusted?
  Satterthwaite <- FALSE # for now
  # if(any(test %in% c("mean.var.adjusted", "scaled.shifted"))) {
  #    Satterthwaite <- TRUE
  # }

  # FIXME: should we not always use 'unstructured' here?
  # if the model is, say, the independence model, the
  # 'structured' information (A1) will be so far away from B1
  # that we will end up with 'NA'
  h1.options <- lavoptions
  if (test == "yuan.bentler.mplus") {
    # always 'unstructured' H1 information
    h1.options$h1.information <- "unstructured"
  }

  # A1 is usually expected or observed
  A1.group <- lav_model_h1_information(
    lavmodel = lavmodel,
    lavsamplestats = lavsamplestats,
    lavdata = lavdata,
    lavimplied = lavimplied,
    lavh1 = lavh1,
    lavoptions = h1.options
  )
  # B1 is always first.order
  B1.group <- lav_model_h1_information_firstorder(
    lavmodel = lavmodel,
    lavsamplestats = lavsamplestats,
    lavdata = lavdata,
    lavimplied = lavimplied,
    lavh1 = lavh1,
    lavoptions = h1.options
  )

  if (test == "yuan.bentler.mplus") {
    if (is.null(B0.group)) {
      B0 <- lav_model_information_firstorder(
        lavmodel = lavmodel,
        lavsamplestats = lavsamplestats,
        lavdata = lavdata,
        lavh1 = lavh1,
        lavoptions = lavoptions,
        extra = TRUE,
        check.pd = FALSE,
        augmented = FALSE,
        inverted = FALSE
      )
      B0.group <- attr(B0, "B0.group")
    }
    trace.UGamma <-
      lav_test_yuan_bentler_mplus_trace(
        lavsamplestats = lavsamplestats,
        A1.group = A1.group,
        B1.group = B1.group,
        B0.group = B0.group,
        E.inv = E.inv,
        meanstructure = lavmodel@meanstructure
      )
  } else if (test == "yuan.bentler") {
    # compute Delta
    Delta <- lav_model_delta(lavmodel = lavmodel)

    # compute Omega/Gamma
    Omega <- lav_model_h1_omega(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats,
      lavdata = lavdata,
      lavimplied = lavimplied,
      lavh1 = lavh1,
      lavoptions = lavoptions
    )

    # compute trace 'U %*% Gamma' (or 'U %*% Omega')
    trace.UGamma <- lav_test_yuan_bentler_trace(
      lavsamplestats   = lavsamplestats,
      meanstructure    = lavmodel@meanstructure,
      A1.group         = A1.group,
      B1.group         = B1.group,
      Delta            = Delta,
      Omega            = Omega,
      E.inv            = E.inv,
      ug2.old.approach = ug2.old.approach,
      Satterthwaite    = FALSE
    ) # for now
  }

  # unscaled test
  df <- TEST$standard$df

  scaling.factor <- trace.UGamma / df
  if (scaling.factor < 0) scaling.factor <- as.numeric(NA)
  chisq.scaled <- TEST$standard$stat / scaling.factor
  pvalue.scaled <- 1 - pchisq(chisq.scaled, df)

  ndat <- sum(attr(trace.UGamma, "h1.ndat"))
  npar <- lavmodel@nx.free

  scaling.factor.h1 <- sum(attr(trace.UGamma, "h1")) / ndat
  scaling.factor.h0 <- sum(attr(trace.UGamma, "h0")) / npar
  trace.UGamma2 <- attr(trace.UGamma, "trace.UGamma2")
  attributes(trace.UGamma) <- NULL

  if ("yuan.bentler" %in% test) {
    TEST$yuan.bentler <-
      list(
        test = test,
        stat = chisq.scaled,
        stat.group = (TEST$standard$stat.group /
          scaling.factor),
        df = df,
        pvalue = pvalue.scaled,
        scaling.factor = scaling.factor,
        scaling.factor.h1 = scaling.factor.h1,
        scaling.factor.h0 = scaling.factor.h0,
        label = "Yuan-Bentler correction",
        trace.UGamma = trace.UGamma,
        trace.UGamma2 = trace.UGamma2,
        scaled.test.stat = TEST$standard$stat,
        scaled.test = TEST$standard$test
      )
  } else if ("yuan.bentler.mplus" %in% test) {
    TEST$yuan.bentler.mplus <-
      list(
        test = test,
        stat = chisq.scaled,
        stat.group = (TEST$standard$stat.group /
          scaling.factor),
        df = df,
        pvalue = pvalue.scaled,
        scaling.factor = scaling.factor,
        scaling.factor.h1 = scaling.factor.h1,
        scaling.factor.h0 = scaling.factor.h0,
        label =
          "Yuan-Bentler correction (Mplus variant)",
        trace.UGamma = trace.UGamma,
        trace.UGamma2 = as.numeric(NA),
        scaled.test.stat = TEST$standard$stat,
        scaled.test = TEST$standard$test
      )
  }

  TEST
}


lav_test_yuan_bentler_trace <- function(lavsamplestats = lavsamplestats,
                                        meanstructure = TRUE,
                                        A1.group = NULL,
                                        B1.group = NULL,
                                        Delta = NULL,
                                        Omega = NULL,
                                        E.inv = NULL,
                                        ug2.old.approach = FALSE,
                                        Satterthwaite = FALSE) {
  # we always assume a meanstructure (nope, not any longer, since 0.6)
  # meanstructure <- TRUE

  ngroups <- lavsamplestats@ngroups

  trace.h1 <- attr(Omega, "trace.h1")
  h1.ndat <- attr(Omega, "h1.ndat")

  if (ug2.old.approach || !Satterthwaite) {
    trace.UGamma <- numeric(ngroups)
    trace.UGamma2 <- numeric(ngroups)
    trace.h0 <- numeric(ngroups)

    for (g in 1:ngroups) {
      fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal

      A1 <- A1.group[[g]] * fg
      B1 <- B1.group[[g]] * fg
      DELTA <- Delta[[g]]
      Gamma.g <- Omega[[g]] / fg

      D.Einv.tD <- DELTA %*% tcrossprod(E.inv, DELTA)

      # trace.h1[g] <- sum( B1 * t( A1.inv ) )
      # fg cancels out: trace.h1[g] <- sum( fg*B1 * t( 1/fg*A1.inv ) )
      trace.h0[g] <- sum(B1 * D.Einv.tD)
      # trace.UGamma[g] <- trace.h1[g] - trace.h0[g]
      U <- A1 - A1 %*% D.Einv.tD %*% A1
      trace.UGamma[g] <- sum(U * Gamma.g)

      if (Satterthwaite) {
        UG <- U %*% Gamma.g
        trace.UGamma2[g] <- sum(UG * t(UG))
      }
    } # g
    trace.UGamma <- sum(trace.UGamma)
    attr(trace.UGamma, "h1") <- trace.h1
    attr(trace.UGamma, "h0") <- trace.h0
    attr(trace.UGamma, "h1.ndat") <- h1.ndat
    if (Satterthwaite) {
      attr(trace.UGamma, "trace.UGamma2") <- sum(trace.UGamma2)
    }
  } else {
    trace.UGamma <- trace.UGamma2 <- UG <- as.numeric(NA)
    fg <- unlist(lavsamplestats@nobs) / lavsamplestats@ntotal
    # if(Satterthwaite) {

    A1.f <- A1.group
    for (g in 1:ngroups) {
      A1.f[[g]] <- A1.group[[g]] * fg[g]
    }
    A1.all <- lav_matrix_bdiag(A1.f)

    B1.f <- B1.group
    for (g in 1:ngroups) {
      B1.f[[g]] <- B1.group[[g]] * fg[g]
    }
    B1.all <- lav_matrix_bdiag(B1.f)

    Gamma.f <- Omega
    for (g in 1:ngroups) {
      Gamma.f[[g]] <- 1 / fg[g] * Omega[[g]]
    }
    Gamma.all <- lav_matrix_bdiag(Gamma.f)
    Delta.all <- do.call("rbind", Delta)

    D.Einv.tD <- Delta.all %*% tcrossprod(E.inv, Delta.all)

    trace.h0 <- sum(B1.all * D.Einv.tD)
    U.all <- A1.all - A1.all %*% D.Einv.tD %*% A1.all
    trace.UGamma <- sum(U.all * Gamma.all)

    attr(trace.UGamma, "h1") <- sum(trace.h1)
    attr(trace.UGamma, "h0") <- trace.h0
    attr(trace.UGamma, "h1.ndat") <- sum(h1.ndat)
    if (Satterthwaite) {
      UG <- U.all %*% Gamma.all
      trace.UGamma2 <- sum(UG * t(UG))
      attr(trace.UGamma, "trace.UGamma2") <- trace.UGamma2
    }

    # } else {
  }

  trace.UGamma
}

lav_test_yuan_bentler_mplus_trace <- function(lavsamplestats = NULL,
                                              A1.group = NULL,
                                              B1.group = NULL,
                                              B0.group = NULL,
                                              E.inv = NULL,
                                              meanstructure = TRUE) {
  # typical for Mplus:
  # - do NOT use the YB formula, but use an approximation
  #   relying  on A0 ~= Delta' A1 Delta and the same for B0
  #
  # NOTE: if A0 is based on the hessian, then A0 only approximates
  #       Delta' A1 Delta
  #
  # - always use h1.information = "unstructured"!!!

  ngroups <- lavsamplestats@ngroups

  trace.UGamma <- numeric(lavsamplestats@ngroups)
  trace.h1 <- numeric(lavsamplestats@ngroups)
  trace.h0 <- numeric(lavsamplestats@ngroups)
  h1.ndat <- numeric(lavsamplestats@ngroups)

  for (g in 1:lavsamplestats@ngroups) {
    # group weight
    fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal

    A1 <- A1.group[[g]]
    B1 <- B1.group[[g]]

    # mask independent 'fixed-x' variables
    zero.idx <- which(diag(A1) == 0)
    if (length(zero.idx) > 0L) {
      A1.inv <- matrix(0, nrow(A1), ncol(A1))
      a1 <- A1[-zero.idx, -zero.idx]
      a1.inv <- solve(a1)
      A1.inv[-zero.idx, -zero.idx] <- a1.inv
    } else {
      A1.inv <- solve(A1)
    }
    h1.ndat[g] <- ncol(A1) - length(zero.idx)

    # if data is complete, why not just A1 %*% Gamma?
    trace.h1[g] <- sum(B1 * t(A1.inv))
    trace.h0[g] <- fg * sum(B0.group[[g]] * t(E.inv))
    trace.UGamma[g] <- (trace.h1[g] - trace.h0[g])
  }

  # we take the sum here
  trace.UGamma <- sum(trace.UGamma)

  attr(trace.UGamma, "h1") <- trace.h1
  attr(trace.UGamma, "h0") <- trace.h0
  attr(trace.UGamma, "h1.ndat") <- h1.ndat

  trace.UGamma
}

# compute two-step standard errors for SAM models
#
# several possibilities:
# 1) se = "twostep": classic (but global) two-step corrected SEs
#     - create 'global' model, only to get the 'joint' information matrix
#     - partition information matrix (step 1, step 2)
#     - apply two-step correction for second step
#     - 'insert' these corrected SEs (and vcov) in JOINT
# 2) se = "standard": using I.22.inv (but without correction term)
# 3) se = "naive": grab (naive) VCOV from FIT.PA
# 4) se = "local": grab (robust) VCOV from FIT.PA

lav_sam_step2_se <- function(FIT = NULL, JOINT = NULL,
                             STEP1 = NULL, STEP2 = NULL,
                             local.options = list()) {
  out <- list()
  Sigma.11 <- STEP1$Sigma.11
  step1.free.idx <- STEP1$step1.free.idx
  step2.free.idx <- STEP2$step2.free.idx
  lavoptions <- FIT@Options
  nlevels <- FIT@pta$nlevels
  FIT.PA <- STEP2$FIT.PA
  extra.id <- STEP2$extra.id

  # catch empty step2.free.idx
  if (length(step2.free.idx) == 0L) {
    # no (free) structural parameters at all!
    out <- list(
      V1 = matrix(0, 0, 0), V2 = matrix(0, 0, 0),
      VCOV = matrix(0, 0, 0)
    )
    return(out)
  }

  if (!lavoptions$se %in%
    c("none", "standard", "naive", "twostep", "twostep.robust",
      "local", "local.nt")) {
    lav_msg_warn(gettextf(
      "unknown se= argument: %s. Switching to twostep.",
      lavoptions$se
    ))
  }

  if (lavoptions$se == "none") {
    return(out)
  }

  if (lav_verbose()) {
    cat("Computing ", lavoptions$se, " standard errors ... ", sep = "")
  }

  if (lavoptions$se %in% c("naive", "twostep", "twostep.robust")) {
    INFO <- lavInspect(JOINT, "information")
    I.12 <- INFO[step1.free.idx, step2.free.idx]
    I.22 <- INFO[step2.free.idx, step2.free.idx]
    I.21 <- INFO[step2.free.idx, step1.free.idx]
  }

  # V2
  if (nlevels > 1L) {
    # FIXME: not ok for multigroup multilevel
    N <- FIT@Data@Lp[[1]]$nclusters[[2]] # first group only
  } else {
    N <- nobs(FIT)
  }

  # total number of free parameters STRUC
  if (FIT.PA@Model@ceq.simple.only) {
    npar <- FIT.PA@Model@nx.unco
    PTS.free <- FIT.PA@ParTable$free
    PTS.free[PTS.free > 0] <- seq_len(npar)
  } else {
    npar <- FIT.PA@Model@nx.free
    PTS.free <- FIT.PA@ParTable$free
  }

  # do we have 'extra' free parameter in FIT.PA that are not free in JOINT?
  step2.rm.idx <- integer(0L)
  if (length(extra.id) > 0L) {
    id.idx <- which(FIT.PA@ParTable$id %in% extra.id &
      FIT.PA@ParTable$free > 0L)
    step2.rm.idx <- PTS.free[id.idx]
  }

  # Fix for EFA/ESEM: when rotation is used, FIT.PA@Model@con.jac includes
  # columns for rotation identification constraints that are not part of
  # step2.free.idx. These extra columns cause dimension mismatch in
  # lav_model_information_augment_invert(). Remove them via rm.idx.
  if (nrow(FIT.PA@Model@con.jac) > 0L) {
    n_jac_cols <- ncol(FIT.PA@Model@con.jac)
    n_step2 <- length(step2.free.idx)
    if (n_jac_cols > n_step2) {
      step2.rm.idx <- union(step2.rm.idx, (n_step2 + 1):n_jac_cols)
    }
  }

  # invert augmented information, for I.22 block only
  # new in 0.6-16 (otherwise, eq constraints in struc part are ignored)
  if (lavoptions$se %in% c("standard", "twostep", "twostep.robust")) {
    I.22.inv <-
      lav_model_information_augment_invert(
        lavmodel = FIT.PA@Model,
        information = I.22,
        inverted = TRUE,
        use.ginv = FALSE, # if interaction, SEs end up smaller than naive...
        rm.idx = step2.rm.idx
      )
    if (inherits(I.22.inv, "try-error")) {
      # hm, not good
      if (lavoptions$se != "naive") {
        lav_msg_warn(gettext(
          "problem inverting information matrix (I.22); -> switching
            to naive standard errors!"
        ))
        lavoptions$se <- "naive"
      }
    }
  } # se needs I.22.inv

  # method below has the advantage that we can use a 'robust' vcov
  # for the joint model;
  # but does not work if we have equality constraints in the MM!
  # -> D will be singular
  # A <- JOINT@vcov$vcov[ step2.free.idx,  step2.free.idx]
  # B <- JOINT@vcov$vcov[ step2.free.idx, -step2.free.idx]
  # C <- JOINT@vcov$vcov[-step2.free.idx,  step2.free.idx]
  # D <- JOINT@vcov$vcov[-step2.free.idx, -step2.free.idx]
  # I.22.inv <- A - B %*% solve(D) %*% C

  # se = "standard"
  if (lavoptions$se == "standard") {
    VCOV <- 1 / N * I.22.inv
    out$VCOV <- VCOV

  # se = "naive" or "local": grab VCOV directly from FIT.PA
  } else if (lavoptions$se %in% c("naive", "local", "local.nt")) {
    if (is.null(FIT.PA@vcov$vcov)) {
      FIT.PA@Options$se <- "standard"
      VCOV <- lavTech(FIT.PA, "vcov")
    } else {
      VCOV <- FIT.PA@vcov$vcov
    }
    if (length(step2.rm.idx) > 0L) {
      VCOV <- VCOV[-step2.rm.idx, -step2.rm.idx]
    }
    # order rows/cols of VCOV, so that they correspond with the (step 2)
    # parameters of the JOINT model
    idx <- sort.int(STEP2$pt.idx, index.return = TRUE)$ix
    VCOV <- VCOV[idx, idx]

    out$VCOV <- VCOV

  # se = "twostep" or "twostep.robust"
  } else if (lavoptions$se  == "twostep" || lavoptions$se == "twostep.robust") {

    if (lavoptions$se  == "twostep") {
      V2 <- 1 / N * I.22.inv # not the same as FIT.PA@vcov$vcov!!
      V1 <- I.22.inv %*% I.21 %*% Sigma.11 %*% I.12 %*% I.22.inv
    } else if(lavoptions$se == "twostep.robust") {
      # following Yuan & Chan 2002, eqs 4, 10, 11, 12, 13 and 14
      # but for V11, V12, V21, V22: we use index '1' for step1, and '2'
      # for step 2!!

      A <- -1 * INFO[step2.free.idx, step2.free.idx, drop = FALSE]
      B <- -1 * INFO[step2.free.idx, step1.free.idx, drop = FALSE]

      # get P (for a single group!! for now)
      P <- lav_sam_step1_local_jac(STEP1 = STEP1, FIT = FIT, P.only = TRUE)

      # get V22
      if (is.null(JOINT@SampleStats@NACOV[[1]])) {
        JOINT@SampleStats@NACOV <- lavTech(JOINT, "gamma")
      }
      tmp <- lav_model_nvcov_robust_sem(
        lavmodel = JOINT@Model, lavsamplestats = JOINT@SampleStats,
        lavcache = JOINT@cache, lavdata = JOINT@Data,
        lavimplied = JOINT@implied, lavh1 = JOINT@h1,
        lavoptions = JOINT@Options, use.ginv = FALSE,
        attr.Delta = TRUE, attr.tDVGVD = TRUE, attr.E.inv = TRUE,
        attr.WLS.V = TRUE)
      NVarCov <- tmp[,] # remove attributes
      Delta <- attr(tmp, "Delta")
      E.inv <- attr(tmp, "E.inv")
      WLS.V <- attr(tmp, "WLS.V")
      tDVGVD <- attr(tmp, "tDVGVD")

      V22 <- tDVGVD[ step2.free.idx, step2.free.idx, drop = FALSE] # ok

      # FIXME: for a single group only:
      V11 <- P %*% lavTech(JOINT, "gamma")[[1]] %*% t(P)
      V21 <- t(Delta[[1]][, step2.free.idx]) %*% WLS.V[[1]] %*% lavTech(JOINT, "gamma")[[1]] %*% t(P)
      V12 <- t(V21)

      #V11 <- NVarCov[step1.free.idx, step1.free.idx, drop = FALSE]
      #V21 <- tmp2[   step2.free.idx, step1.free.idx, drop = FALSE]
      #PI <- V22 + B %*% V12 + V21 %*% t(B) + B %*% V11 %*% t(B)
      #A.inv <- solve(A)
      A.inv <-  -1 * I.22.inv
      #VCOV <- A.inv %*% PI %*% t(A.inv)
      V2 <- 1/N * (A.inv %*% V22 %*% A.inv)
      V1 <- 1/N * (A.inv %*% (B %*% V12 + V21 %*% t(B) + B %*% V11 %*% t(B)) %*% A.inv)
    }

    # V for second step
    if (!is.null(local.options$alpha.correction) &&
      local.options$alpha.correction > 0) {
      alpha.N1 <- local.options$alpha.correction / (N - 1)
      if (alpha.N1 > 1.0) {
        alpha.N1 <- 1.0
      } else if (alpha.N1 < 0.0) {
        alpha.N1 <- 0.0
      }
      if (is.null(FIT.PA@vcov$vcov)) {
        FIT.PA@Options$se <- "standard"
        VCOV.naive <- lavTech(FIT.PA, "vcov")
      } else {
        VCOV.naive <- FIT.PA@vcov$vcov
      }
      if (length(step2.rm.idx) > 0L) {
        VCOV.naive <- VCOV.naive[-step2.rm.idx, -step2.rm.idx]
      }
      VCOV.corrected <- V2 + V1
      VCOV <- alpha.N1 * VCOV.naive + (1 - alpha.N1) * VCOV.corrected
    } else {
      # no alpha correction
      VCOV <- V2 + V1
    }

    # store in out
    out$V2 <- V2
    out$V1 <- V1
    out$VCOV <- VCOV
  } # twostep

  # store se
  out$se <- lavoptions$se # in case it changed

  if (lav_verbose()) {
    cat("done.\n")
  }

  out
}

# summary information for a single (lavaan) efa model
#
# workflow:
# - summary() first calls lav_efalist_summary()
# - for each model, lav_efalist_summary() calls lav_object_summary() with
#   efa = TRUE and efa.args
# - for each model, lav_object_summary() calls
#   lav_efa_summary(object, efa.args = efa.args) to populate the $efa slot


# efa summary for a single lavaan object
lav_efa_summary <- function(object,
                            efa.args = list(
                              lambda = TRUE,
                              theta = TRUE,
                              psi = TRUE,
                              eigenvalues = TRUE,
                              sumsq.table = TRUE,
                              lambda.structure = FALSE,
                              fs.determinacy = FALSE,
                              se = FALSE,
                              zstat = FALSE,
                              pvalue = FALSE
                            )) {
  stopifnot(inherits(object, "lavaan"))

  nblocks <- object@Model@nblocks
  orthogonal.flag <- object@Options$rotation.args$orthogonal

  # get standardized solution
  LAMBDA <- THETA <- PSI <- NULL
  STD <- lavTech(object, "std",
    add.class = TRUE, add.labels = TRUE,
    list.by.group = FALSE
  )
  lambda.idx <- which(names(STD) == "lambda")
  theta.idx <- which(names(STD) == "theta")
  psi.idx <- which(names(STD) == "psi")

  # LAMBDA
  LAMBDA <- STD[lambda.idx]
  names(LAMBDA) <- NULL

  # THETA
  THETA <- STD[theta.idx]
  # make THETA diagonal
  THETA <- lapply(seq_len(nblocks), function(b) {
    tmp <- diag(THETA[[b]])
    class(tmp) <- c("lavaan.vector", "numeric")
    tmp
  })

  # PSI
  PSI <- STD[psi.idx]
  names(PSI) <- NULL

  # eigenvalues correlation matrix
  std.ov <- object@Options$rotation.args$std.ov
  COV <- object@h1$implied$cov # h1
  if (std.ov) {
    COV <- lapply(COV, cov2cor)
  }
  eigvals <- NULL
  if (efa.args$eigenvalues) {
    eigvals <- lapply(seq_len(nblocks), function(b) {
      tmp <- eigen(COV[[b]], only.values = TRUE)$values
      names(tmp) <- paste("ev", 1:nrow(LAMBDA[[b]]), sep = "")
      class(tmp) <- c("lavaan.vector", "numeric")
      tmp
    })
  }

  fs.determinacy <- NULL
  # Note: these 'determinacy' values are only properly defined for the
  #       'regression' factor scores! (If we would apply the same formulas
  #       for Bartlett factor scores, we would obtain 1's!
  if (efa.args$fs.determinacy) {
    fs.determinacy <- lapply(seq_len(nblocks), function(b) {
      COR <- cov2cor(COV[[b]]) # just in case
      COR.inv <- try(solve(COR), silent = TRUE)
      if (inherits(COR.inv, "try-error")) {
        return(rep(as.numeric(NA), nrow(PSI[[b]])))
      }
      fs <- LAMBDA[[b]] %*% PSI[[b]] # factor structure
      out <- sqrt(diag(t(fs) %*% COR.inv %*% fs))
      class(out) <- c("lavaan.vector", "numeric")
      out
    })
  }

  # sum-of-squares table
  sumsq.table <- NULL
  if (efa.args$sumsq.table) {
    sumsq.table <- lapply(seq_len(nblocks), function(b) {
      nvar <- nrow(LAMBDA[[b]])
      nfactor <- ncol(LAMBDA[[b]])

      # sum of squares:
      # - if orthogonal, this is really the sum of the squared factor
      #   loadings
      # - if oblique, we need to take the correlation into account
      sumsq <- diag(PSI[[b]] %*% crossprod(LAMBDA[[b]]))

      # reorder
      if (nfactor > 1L) {
        # determine order
        order.idx <- sort.int(sumsq, decreasing = TRUE, index.return = TRUE)$ix
        # re-order from large to small
        sumsq <- sumsq[order.idx]
      }

      # Proportion 'explained' (= proportion of total sumsq)
      #   note: sum(sumsq) == sum(communalities)
      propexpl <- sumsq / sum(sumsq)

      # Proportion var (= sumsq/nvar)
      propvar <- sumsq / nrow(LAMBDA[[b]])

      # Cumulative var
      cumvar <- cumsum(propvar)

      # construct table
      tmp <- rbind(sumsq, propexpl, propvar, cumvar)

      # total + colnames
      if (nfactor > 1L) {
        # add total column
        tmp <- cbind(tmp, rowSums(tmp))
        tmp[4, ncol(tmp)] <- tmp[3, ncol(tmp)]
        colnames(tmp) <-
          c(
            colnames(LAMBDA[[b]])[order.idx],
            "total"
          )
      } else {
        colnames(tmp) <- colnames(LAMBDA[[b]])[1]
      }

      # rownames
      if (nfactor == 1L) {
        ssq.label <- "Sum of squared loadings"
      } else if (orthogonal.flag) {
        ssq.label <- "Sum of sq (ortho) loadings"
      } else {
        ssq.label <- "Sum of sq (obliq) loadings"
      }
      rownames(tmp) <- c(
        ssq.label,
        "Proportion of total",
        "Proportion var",
        "Cumulative var"
      )

      # class
      class(tmp) <- c("lavaan.matrix", "matrix")

      tmp
    })
  } # sumsq.table

  # (factor) structure coefficients
  if (efa.args$lambda.structure) {
    lambda.structure <- lapply(seq_len(nblocks), function(b) {
      tmp <- LAMBDA[[b]] %*% PSI[[b]]
      class(tmp) <- c("lavaan.matrix", "matrix")
      tmp
    })
  } else {
    lambda.structure <- NULL
  }

  # standard errors (if any)
  lambda.se <- theta.se <- psi.se <- NULL
  lambda.zstat <- theta.zstat <- psi.zstat <- NULL
  lambda.pval <- theta.pval <- psi.pval <- NULL
  if (object@Options$se != "none") {
    SE <- lavTech(object, "std.se",
      add.class = TRUE, add.labels = TRUE,
      list.by.group = FALSE
    )

    se.flag <- (efa.args$se || efa.args$zstat || efa.args$pvalue)

    # ALWAYS use lambda.se
    if (efa.args$lambda) {
      lambda.se <- SE[lambda.idx]
      names(lambda.se) <- NULL
    }

    # theta.se
    if (se.flag && efa.args$theta) {
      theta.se <- SE[theta.idx]
      # make theta.se diagonal
      theta.se <- lapply(seq_len(nblocks), function(b) {
        tmp <- diag(theta.se[[b]])
        class(tmp) <- c("lavaan.vector", "numeric")
        tmp
      })
    }

    # ALWAYS use psi.se
    if (efa.args$psi) {
      psi.se <- SE[psi.idx]
      names(psi.se) <- NULL
    }

    # compute zstat
    if (efa.args$zstat || efa.args$pvalue) {
      if (efa.args$lambda) {
        lambda.zstat <- lapply(seq_len(nblocks), function(b) {
          tmp.se <- lambda.se[[b]]
          tmp.se[tmp.se < sqrt(.Machine$double.eps)] <-
            as.numeric(NA)
          tmp <- LAMBDA[[b]] / tmp.se
          class(tmp) <- c("lavaan.matrix", "matrix")
          tmp
        })
      }
      if (efa.args$theta) {
        theta.zstat <- lapply(seq_len(nblocks), function(b) {
          tmp.se <- theta.se[[b]]
          tmp.se[tmp.se < sqrt(.Machine$double.eps)] <-
            as.numeric(NA)
          tmp <- THETA[[b]] / tmp.se
          class(tmp) <- c("lavaan.vector", "numeric")
          tmp
        })
      }
      if (efa.args$psi) {
        psi.zstat <- lapply(seq_len(nblocks), function(b) {
          tmp.se <- psi.se[[b]]
          tmp.se[tmp.se < sqrt(.Machine$double.eps)] <-
            as.numeric(NA)
          tmp <- PSI[[b]] / tmp.se
          class(tmp) <- c(
            "lavaan.matrix.symmetric",
            "matrix"
          )
          tmp
        })
      }
    }

    # compute pval
    if (efa.args$pvalue) {
      if (efa.args$lambda) {
        lambda.pval <- lapply(seq_len(nblocks), function(b) {
          tmp <- 2 * (1 - pnorm(abs(lambda.zstat[[b]])))
          class(tmp) <- c("lavaan.matrix", "matrix")
          tmp
        })
      }
      if (efa.args$theta) {
        theta.pval <- lapply(seq_len(nblocks), function(b) {
          tmp <- 2 * (1 - pnorm(abs(theta.zstat[[b]])))
          class(tmp) <- c("lavaan.vector", "numeric")
          tmp
        })
      }
      if (efa.args$psi) {
        psi.pval <- lapply(seq_len(nblocks), function(b) {
          tmp <- 2 * (1 - pnorm(abs(psi.zstat[[b]])))
          class(tmp) <- c(
            "lavaan.matrix.symmetric",
            "matrix"
          )
          tmp
        })
      }
    }
  } # se/zstat/pvalue

  # block.label
  block.label <- object@Data@block.label

  # we remove them here; we may have needed them for other parts
  if (!efa.args$lambda) {
    LAMBDA <- NULL
  }
  if (!efa.args$theta) {
    THETA <- NULL
  }
  if (!efa.args$psi) {
    PSI <- NULL
  }
  if (!efa.args$se) {
    # always keep lambda.se and psi.se (for the signif stars)
    theta.se <- NULL
  }
  if (!efa.args$zstat) {
    lambda.zstat <- theta.zstat <- psi.zstat <- NULL
  }

  res <- list(
    nblocks = nblocks,
    block.label = block.label,
    std.ov = std.ov,
    eigvals = eigvals,
    sumsq.table = sumsq.table,
    orthogonal = object@Options$rotation.args$orthogonal,
    lambda.structure = lambda.structure,
    fs.determinacy = fs.determinacy,
    lambda = LAMBDA,
    theta = THETA,
    psi = PSI,
    lambda.se = lambda.se,
    lambda.zstat = lambda.zstat,
    lambda.pvalue = lambda.pval,
    psi.se = psi.se,
    psi.zstat = psi.zstat,
    psi.pvalue = psi.pval,
    theta.se = theta.se,
    theta.zstat = theta.zstat,
    theta.pvalue = theta.pval
  )

  res
}


# summary efaList
lav_efalist_summary <- function(object, nd = 3L, cutoff = 0.3, dot.cutoff = 0.1,
                            alpha.level = 0.01,
                            lambda = TRUE, theta = TRUE, psi = TRUE,
                            fit.table = TRUE, fs.determinacy = FALSE,
                            eigenvalues = TRUE, sumsq.table = TRUE,
                            lambda.structure = FALSE, se = FALSE,
                            zstat = FALSE, pvalue = FALSE, ...) {
  # kill object$loadings if present
  object[["loadings"]] <- NULL

  # unclass the object
  y <- unclass(object)

  # construct efa.args
  efa.args <- list(
    lambda = lambda, theta = theta, psi = psi,
    eigenvalues = eigenvalues, sumsq.table = sumsq.table,
    lambda.structure = lambda.structure,
    fs.determinacy = fs.determinacy,
    se = se, zstat = zstat, pvalue = pvalue
  )

  # extract useful info from first model
  out <- lav_object_summary(y[[1]],
    header = TRUE, estimates = FALSE,
    efa = FALSE
  )

  # header information
  lavaan.version <- out$header$lavaan.version
  converged.flag <- all(sapply(y, lavInspect, "converged"))

  # estimator
  estimator <- out$optim$estimator
  estimator.args <- out$optim$estimator.args

  # rotation
  rotation <- out$rotation$rotation
  rotation.args <- out$rotation$rotation.args

  # data
  lavdata <- out$data

  # main part: lav_object_summary information per model
  RES <- lapply(y, lav_object_summary,
    header = FALSE,
    fit.measures = FALSE, estimates = TRUE, efa = TRUE,
    efa.args = efa.args
  )

  # number of factors (for ALL blocks)
  nfactors <- sapply(y, function(x) x@pta$nfac[[1]])

  # fit.measures
  Table <- NULL
  if (fit.table) {
    # first, create standard table
    FIT <- fitMeasures(object, fit.measures = "default")
    NAMES <- rownames(FIT)
    idx <- integer(0L)

    # AIC/BIC
    if (all(c("aic", "bic", "bic2") %in% NAMES)) {
      this.idx <- match(c("aic", "bic", "bic2"), NAMES)
      idx <- c(idx, this.idx)
    }

    # chi-square
    if (all(c("chisq.scaled", "df.scaled", "pvalue.scaled") %in% NAMES)) {
      this.idx <- match(
        c("chisq.scaled", "df.scaled", "pvalue.scaled"),
        NAMES
      )
      idx <- c(idx, this.idx)
    } else {
      this.idx <- match(c("chisq", "df", "pvalue"), NAMES)
      idx <- c(idx, this.idx)
    }

    # CFI
    if ("cfi.robust" %in% NAMES && !all(is.na(FIT["cfi.robust", ]))) {
      this.idx <- match("cfi.robust", NAMES)
      idx <- c(idx, this.idx)
    } else if ("cfi.scaled" %in% NAMES) {
      this.idx <- match("cfi.scaled", NAMES)
      idx <- c(idx, this.idx)
    } else if ("cfi" %in% NAMES) {
      this.idx <- match("cfi", NAMES)
      idx <- c(idx, this.idx)
    }

    # RMSEA
    if ("rmsea.robust" %in% NAMES && !all(is.na(FIT["rmsea.robust", ]))) {
      this.idx <- match("rmsea.robust", NAMES)
      idx <- c(idx, this.idx)
    } else if ("rmsea.scaled" %in% NAMES) {
      this.idx <- match("rmsea.scaled", NAMES)
      idx <- c(idx, this.idx)
    } else if ("rmsea" %in% NAMES) {
      this.idx <- match("rmsea", NAMES)
      idx <- c(idx, this.idx)
    }

    # table with fitmeasures
    if (length(idx) > 0L) {
      Table <- t(FIT[idx, , drop = FALSE])
      tmp <- NAMES[idx]
      # strip '.scaled'
      tmp <- gsub(".scaled", "", tmp)
      # replace 'robust' by 'r' (if any)
      tmp <- gsub(".robust", "", tmp)
      # rename "bic2" -> "sabic"
      bic2.idx <- which(tmp == "bic2")
      if (length(bic2.idx) > 0L) {
        tmp[bic2.idx] <- "sabic"
      }
      colnames(Table) <- tmp
    } else {
      Table <- matrix(0, nrow = nfactors, ncol = 0L)
    }
    rownames(Table) <- paste("nfactors = ", nfactors, sep = "")
    class(Table) <- c("lavaan.matrix", "matrix")
  }

  # create return object
  out <- list(
    lavaan.version = lavaan.version,
    converged.flag = converged.flag,
    estimator = estimator,
    estimator.args = estimator.args,
    rotation = rotation,
    rotation.args = rotation.args,
    lavdata = lavdata,
    fit.table = Table,
    nfactors = nfactors,
    model.list = RES
  )

  # add nd, cutoff, dot.cutoff, ... as attributes (for printing)
  attr(out, "nd") <- nd
  attr(out, "cutoff") <- cutoff
  attr(out, "dot.cutoff") <- dot.cutoff
  attr(out, "alpha.level") <- alpha.level

  # create class
  class(out) <- c("efaList.summary", "list")

  out
}

lav_label_code <- function(label = "", value = "", show = FALSE,
                           idx.font.size = 20L, dy = 7L,
                           italic = TRUE, auto.subscript = TRUE) {
  latexsymbols <- c("varepsilon",
    "Alpha", "Beta", "Gamma", "Delta", "Epsilon", "Zeta", "Eta", "Theta",
    "Iota", "Kappa", "Lambda", "Mu", "Nu", "Xi", "Omicron", "Pi",
    "Rho", "Sigma", "Tau", "Upsilon", "Phi", "Chi", "Psi", "Omega",
    "alpha", "beta", "gamma", "delta", "epsilon", "zeta", "eta", "theta",
    "iota", "kappa", "lambda", "mu", "nu", "xi", "omicron", "pi",
    "rho", "sigma", "tau", "upsilon", "phi", "chi", "psi", "omega"
  )
  unicodes <- c("1013",
    "913", "914", "915", "916", "917", "918", "919", "920",
    "921", "922", "923", "924", "925", "926", "927", "928",
    "929", "931", "932", "933", "934", "935", "936", "937",
    "945", "946", "947", "948", "949", "950", "951", "952",
    "953", "954", "955", "956", "957", "958", "959", "960",
    "961", "963", "964", "965", "966", "967", "968", "969"
  )
  if (label == "" && value == "") return(list(svg = "", tikz = "", r = ""))
  if (auto.subscript) {
    label <- gsub("^([a-zA-Z]+)([0-9]+)", "\\1_\\2", label)
  }
  rexpression <- FALSE
  if (grepl("1van", label)) label <- "1"
  if (value == "") {
    splitted <- strsplit(label, "=", fixed =  TRUE)[[1L]]
    if (length(splitted) > 1L) {
      label <- splitted[1L]
      value <- splitted[2L]
    }
  }
  if (label == "") {
    label <- value
    value <- ""
  }
  svgpart <- tikzpart <- rpart <- character(3)
  rpart[3L] <- tikzpart[3L] <- svgpart[3L] <- value
  if (label != "") {
    # separate label and value by equal sign
    if (svgpart[3L] != "") svgpart[3L] <- paste0("=", svgpart[3L])
    if (tikzpart[3L] != "") tikzpart[3L] <- paste0("=", tikzpart[3L])
    if (rpart[3L] != "") {
      rpart[3L] <- paste0(" == ", rpart[3L])
      rexpression <- TRUE
    }
    # subscript and Greek character set handling
    splitunderscore <- strsplit(label, "_", TRUE)[[1L]]
    svgpart[1] <- tikzpart[1] <- rpart[1] <- splitunderscore[1L]
    if (rpart[1] %in% latexsymbols) {
      rexpression <- TRUE
      svgpart[1] <- paste0("&#", unicodes[latexsymbols == svgpart[1]], ";")
      tikzpart[1] <- paste0("\\", tikzpart[1])
      if (rpart[1] == "varepsilon") rpart[1] <- "epsilon"
      rpart[1] <- str2expression(rpart[1])
    }
    if (length(splitunderscore) > 1L) {
      rexpression <- TRUE
      svgpart[2L] <- paste0("<tspan dy=\"", dy  ,"\" font-size=\"",
                     idx.font.size, "\">", splitunderscore[2L], "</tspan>")
      if (svgpart[3L] != "") {
        svgpart[3L] <- paste0("<tspan dy=\"-", dy, "\">",
                               svgpart[3L], "</tspan>")
      }
      tikzpart[2L] <- paste0("_{", splitunderscore[2L], "}")
      rpart[2L] <- paste0("[\"", splitunderscore[2L], "\"]")
    }
    if (!italic) tikzpart <- c("\\mathrm{", tikzpart, "}")
  }
  if (show) {
    plot(c(0,3), c(0,2), type = "n")
    if (rexpression) {
      text(1, 1, str2expression(paste(rpart, collapse = "")))
    } else {
      text(1, 1, paste(rpart, collapse = ""), font = ifelse(italic, 3L, 1L))
    }
  }
  list(svg = paste(svgpart, collapse = ""),
       tikz = paste(c("$", tikzpart, "$"), collapse = ""),
       r = ifelse(rexpression,
         str2expression(paste(rpart, collapse = "")),
         paste(rpart, collapse = ""))
  )
}

# the weighted bivariate ordinal/linear model
# YR 08 March 2020 (replacing the old lav_polyserial.R routines)
#
# - polyserial (and biserial) correlations
# - bivariate ordinal/linear regression
# - using sampling weights wt


# polyserial correlation
#
# Y1 = linear
# Y2 = ordinal
lav_bvmix_cor_twostep_fit <- function(Y1, Y2, eXo = NULL, wt = NULL,
                                      fit.y1 = NULL, fit.y2 = NULL,
                                      Y1.name = NULL, Y2.name = NULL,
                                      optim.method = "nlminb1", # 0.6-7
                                      optim.scale = 1.0,
                                      init.theta = NULL,
                                      control = list()) {
  if (is.null(fit.y1)) {
    fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt)
  }
  if (is.null(fit.y2)) {
    fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt)
  }

  # create cache environment
  cache <- lav_bvmix_init_cache(fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt)

  # optim.method
  minObjective <- lav_bvmix_min_objective
  minGradient <- lav_bvmix_min_gradient
  minHessian <- lav_bvmix_min_hessian
  if (optim.method == "nlminb" || optim.method == "nlminb2") {
    # nothing to do
  } else if (optim.method == "nlminb0") {
    minGradient <- minHessian <- NULL
  } else if (optim.method == "nlminb1") {
    minHessian <- NULL
  }

  # optimize
  if (is.null(control$trace)) {
    control$trace <- ifelse(lav_verbose(), 1, 0)
  }

  # init theta?
  if (!is.null(init.theta)) {
    start.x <- init.theta
  } else {
    start.x <- cache$theta
  }

  # try 1
  optim <- nlminb(
    start = start.x, objective = minObjective,
    gradient = minGradient, hessian = minHessian,
    control = control,
    scale = optim.scale, lower = -0.995, upper = +0.995,
    cache = cache
  )

  # try 2
  if (optim$convergence != 0L) {
    optim <- nlminb(
      start = start.x, objective = minObjective,
      gradient = NULL, hessian = NULL,
      control = control,
      scale = optim.scale, lower = -0.995, upper = +0.995,
      cache = cache
    )
  }

  # try 3
  if (optim$convergence != 0L) {
    optim <- nlminb(
      start = 0, objective = minObjective,
      gradient = NULL, hessian = NULL,
      control = control,
      scale = 10, lower = -0.995, upper = +0.995,
      cache = cache
    )
  }

  # try 4 -- new in 0.6-8
  if (optim$convergence != 0L) {
    optim <- optimize(
      f = minObjective, interval = c(-0.995, +0.995),
      cache = cache, tol = .Machine$double.eps
    )
    if (is.finite(optim$minimum)) {
      optim$convergence <- 0L
      optim$par <- optim$minimum
    }
  }

  # check convergence
  if (optim$convergence != 0L) {
    if (!is.null(Y1.name) && !is.null(Y2.name)) {
      lav_msg_warn(gettextf(
        "estimation polyserial correlation did not converge
        for variables %1$s and %2$s", Y1.name, Y2.name))
    } else {
      lav_msg_warn(gettext(
        "estimation polyserial correlation(s) did not always converge"))
    }
    rho <- cache$theta # starting value
  } else {
    rho <- optim$par
  }

  rho
}


# Y1 = linear
# Y2 = ordinal
lav_bvmix_init_cache <- function(fit.y1 = NULL,
                                 fit.y2 = NULL,
                                 wt = NULL,
                                 scores = FALSE,
                                 parent = parent.frame()) {
  # data
  Y1 <- fit.y1$y
  Y2 <- fit.y2$y
  eXo <- fit.y1$X

  # extract parameters

  # Y1
  y1.VAR <- fit.y1$theta[fit.y1$var.idx]
  y1.SD <- sqrt(y1.VAR)
  y1.ETA <- fit.y1$yhat
  Z <- (Y1 - y1.ETA) / y1.SD

  # Y2
  th.y2 <- fit.y2$theta[fit.y2$th.idx]

  # exo?
  if (is.null(eXo)) {
    nexo <- 0L
  } else {
    nexo <- ncol(eXo)
  }

  # nobs
  if (is.null(wt)) {
    N <- length(Y1)
  } else {
    N <- sum(wt)
  }

  # starting value -- Olsson 1982 eq 38
  if (nexo > 0L) {
    # exo
    if (is.null(wt)) {
      COR <- cor(Z, Y2, use = "pairwise.complete.obs")
      SD <- sd(Y2, na.rm = TRUE) * sqrt((N - 1) / N)
    } else {
      tmp <- na.omit(cbind(Z, Y2, wt))
      COR <- cov.wt(x = tmp[, 1:2], wt = tmp[, 3], cor = TRUE)$cor[2, 1]
      SD <- sqrt(lav_matrix_var_wt(tmp[, 2], wt = tmp[, 3]))
    }
    rho.init <- (COR * SD / sum(dnorm(th.y2)))
  } else {
    # no exo
    if (is.null(wt)) {
      COR <- cor(Y1, Y2, use = "pairwise.complete.obs")
      SD <- sd(Y2, na.rm = TRUE) * sqrt((N - 1) / N)
    } else {
      tmp <- na.omit(cbind(Y1, Y2, wt))
      COR <- cov.wt(x = tmp[, 1:2], wt = tmp[, 3], cor = TRUE)$cor[2, 1]
      SD <- sqrt(lav_matrix_var_wt(tmp[, 2], wt = tmp[, 3]))
    }
    rho.init <- (COR * SD / sum(dnorm(th.y2)))
  }

  # sanity check
  if (is.na(rho.init)) {
    rho.init <- 0.0
  } else if (abs(rho.init) > 0.9) {
    rho.init <- rho.init / 2
  }

  # parameter vector
  theta <- rho.init # only

  # different cache if scores or not
  if (scores) {
    out <- list2env(
      list(
        nexo = nexo, theta = theta, N = N,
        y1.VAR = y1.VAR, eXo = eXo,
        y2.Y1 = fit.y2$Y1, y2.Y2 = fit.y2$Y2,
        Y1 = Y1, y1.SD = y1.SD, y1.ETA = y1.ETA, Z = Z,
        fit.y2.z1 = fit.y2$z1, fit.y2.z2 = fit.y2$z2
      ),
      parent = parent
    )
  } else {
    out <- list2env(
      list(
        nexo = nexo, theta = theta, N = N,
        Y1 = Y1, y1.SD = y1.SD, y1.ETA = y1.ETA, Z = Z,
        fit.y2.z1 = fit.y2$z1, fit.y2.z2 = fit.y2$z2
      ),
      parent = parent
    )
  }

  out
}


# casewise likelihoods, unweighted!
lav_bvmix_lik_cache <- function(cache = NULL) {
  with(cache, {
    rho <- theta[1L]
    R <- sqrt(1 - rho * rho)

    # p(Y2|Y1)
    tauj.star <- (fit.y2.z1 - rho * Z) / R
    tauj1.star <- (fit.y2.z2 - rho * Z) / R
    py2y1 <- pnorm(tauj.star) - pnorm(tauj1.star)
    # TODO, check when to use 1 - pnorm()
    py2y1[py2y1 < .Machine$double.eps] <- .Machine$double.eps

    # p(Y1)
    py1 <- dnorm(Y1, mean = y1.ETA, sd = y1.SD)

    # lik
    lik <- py1 * py2y1

    # catch very small values
    lik.toosmall.idx <- which(lik < sqrt(.Machine$double.eps))
    lik[lik.toosmall.idx] <- as.numeric(NA)

    return(lik)
  })
}

lav_bvmix_logl_cache <- function(cache = NULL) {
  with(cache, {
    lik <- lav_bvmix_lik_cache(cache) # unweighted!

    if (!is.null(wt)) {
      logl <- sum(wt * log(lik), na.rm = TRUE)
    } else {
      logl <- sum(log(lik), na.rm = TRUE)
    }

    return(logl)
  })
}

lav_bvmix_gradient_cache <- function(cache = NULL) {
  with(cache, {
    rho <- theta[1L]

    y.Z1 <- dnorm(tauj.star)
    y.Z2 <- dnorm(tauj1.star)
    pyx.inv.R3 <- 1 / (py2y1 * R * R * R)

    # rho
    d1 <- fit.y2.z1 * rho - Z
    d2 <- fit.y2.z2 * rho - Z
    dx <- pyx.inv.R3 * (y.Z1 * d1 - y.Z2 * d2)

    # to be consistent with (log)lik_cache
    if (length(lik.toosmall.idx) > 0L) {
      dx[lik.toosmall.idx] <- as.numeric(NA)
    }

    if (is.null(wt)) {
      dx.rho <- sum(dx, na.rm = TRUE)
    } else {
      dx.rho <- sum(wt * dx, na.rm = TRUE)
    }

    return(dx.rho)
  })
}

# YR 29 March 2020
# obtained by using 'Deriv' (from package Deriv) on the
# gradient function, and cleaning up
# correct, but not good enough
lav_bvmix_hessian_cache <- function(cache = NULL) {
  with(cache, {
    rho <- theta[1L]
    R2 <- R * R

    t1 <- Z - rho * tauj.star / R
    t2 <- Z - rho * tauj1.star / R

    tmp <- (y.Z1 * (d1 * ((3 * rho / R2) + tauj.star * t1 / R)
      + fit.y2.z1 + dx * R2 * t1)

    - y.Z2 * (d2 * ((3 * rho / R2) + tauj1.star * t2 / R)
        + fit.y2.z2 + dx * R2 * t2)
    )

    # to be consistent with (log)lik_cache
    if (length(lik.toosmall.idx) > 0L) {
      tmp[lik.toosmall.idx] <- as.numeric(NA)
    }

    if (is.null(wt)) {
      H <- sum(tmp * pyx.inv.R3, na.rm = TRUE)
    } else {
      H <- sum(wt * (tmp * pyx.inv.R3), na.rm = TRUE)
    }
    dim(H) <- c(1L, 1L) # for nlminb

    return(H)
  })
}

# compute total (log)likelihood, for specific 'x' (nlminb)
lav_bvmix_min_objective <- function(x, cache = NULL) {
  cache$theta <- x
  -1 * lav_bvmix_logl_cache(cache = cache) / cache$N
}

# compute gradient, for specific 'x' (nlminb)
lav_bvmix_min_gradient <- function(x, cache = NULL) {
  # check if x has changed
  if (!all(x == cache$theta)) {
    cache$theta <- x
    tmp <- lav_bvmix_logl_cache(cache = cache)
  }
  -1 * lav_bvmix_gradient_cache(cache = cache) / cache$N
}

# compute hessian, for specific 'x' (nlminb)
lav_bvmix_min_hessian <- function(x, cache = NULL) {
  # check if x has changed
  if (!all(x == cache$theta)) {
    tmp <- lav_bvmix_logl_cache(cache = cache)
    tmp <- lav_bvmix_gradient_cache(cache = cache)
  }
  -1 * lav_bvmix_hessian_cache(cache = cache) / cache$N
}


lav_bvmix_cor_scores_cache <- function(cache = NULL,
                                       sigma.correction = FALSE,
                                       na.zero = FALSE) {
  with(cache, {
    rho <- theta[1L]
    R <- sqrt(1 - rho * rho)

    tauj.star <- (fit.y2.z1 - rho * Z) / R
    tauj1.star <- (fit.y2.z2 - rho * Z) / R
    y.Z1 <- dnorm(tauj.star)
    y.Z2 <- dnorm(tauj1.star)

    # p(Y2|Y1)
    py2y1 <- pnorm(tauj.star) - pnorm(tauj1.star)
    py2y1[py2y1 < .Machine$double.eps] <- .Machine$double.eps
    pyx.inv <- 1 / py2y1

    # mu.y1
    y.Z1.y.Z2 <- y.Z1 - y.Z2
    dx.mu.y1 <- 1 / y1.SD * (Z + (pyx.inv * (rho / R) * y.Z1.y.Z2))
    if (!is.null(wt)) {
      dx.mu.y1 <- wt * dx.mu.y1
    }

    # var.y1
    dx.var.y1 <- 1 / (2 * y1.VAR) * (((Z * Z) - 1) +
      (pyx.inv * rho * Z / R) * y.Z1.y.Z2)
    if (!is.null(wt)) {
      dx.var.y1 <- wt * dx.var.y1
    }

    # th.y2
    dx.th.y2 <- (y2.Y1 * y.Z1 - y2.Y2 * y.Z2) * 1 / R * pyx.inv
    if (!is.null(wt)) {
      dx.th.y2 <- wt * dx.th.y2
    }

    # sl.y1
    dx.sl.y1 <- NULL
    if (nexo > 0L) {
      dx.sl.y1 <- dx.mu.y1 * eXo
      # if(!is.null(wt)) {
      # dx.mu.y1 had already been weighted
      # }
    }

    # sl.y2
    dx.sl.y2 <- NULL
    if (nexo > 0L) {
      dx.sl.y2 <- (y.Z2 - y.Z1) * eXo * 1 / R * pyx.inv
      if (!is.null(wt)) {
        dx.sl.y2 <- wt * dx.sl.y2
      }
    }

    # rho
    TAUj <- y.Z1 * (fit.y2.z1 * rho - Z)
    TAUj1 <- y.Z2 * (fit.y2.z2 * rho - Z)
    dx.rho <- pyx.inv * 1 / (R * R * R) * (TAUj - TAUj1)
    if (!is.null(wt)) {
      dx.rho <- wt * dx.rho
    }

    # FIXME: only tested for non_exo!
    # used by lav_pml_dploglik_dimplied()
    if (sigma.correction) {
      dx.rho.orig <- dx.rho
      dx.var.y1.orig <- dx.var.y1

      # sigma
      dx.rho <- dx.rho.orig / y1.SD

      # var
      COV <- rho * y1.SD
      dx.var.y1 <- (dx.var.y1.orig -
        1 / 2 * COV / y1.VAR * 1 / y1.SD * dx.rho.orig)
    }

    out <- list(
      dx.mu.y1 = dx.mu.y1, dx.var.y1 = dx.var.y1,
      dx.th.y2 = dx.th.y2,
      dx.sl.y1 = dx.sl.y1, dx.sl.y2 = dx.sl.y2,
      dx.rho = dx.rho
    )

    return(out)
  })
}


# casewise scores
#
# Y1 = linear
# Y2 = ordinal
lav_bvmix_cor_scores <- function(Y1, Y2, eXo = NULL, wt = NULL,
                                 rho = NULL,
                                 fit.y1 = NULL, fit.y2 = NULL,
                                 evar.y1 = NULL, beta.y1 = NULL,
                                 th.y2 = NULL, sl.y2 = NULL,
                                 sigma.correction = FALSE,
                                 na.zero = FALSE) {
  if (is.null(fit.y1)) {
    fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt)
  }
  if (is.null(fit.y2)) {
    fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt)
  }

  # update z1/z2 if needed (used in lav_pml_dploglik_dimplied() in lav_model_gradient_pml.R)
  fit.y1 <- lav_uvreg_update_fit(
    fit.y = fit.y1, evar.new = evar.y1,
    beta.new = beta.y1
  )
  fit.y2 <- lav_uvord_update_fit(
    fit.y = fit.y2, th.new = th.y2,
    sl.new = sl.y2
  )

  # create cache environment
  cache <- lav_bvmix_init_cache(
    fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt,
    scores = TRUE
  )
  cache$theta <- rho

  SC <- lav_bvmix_cor_scores_cache(
    cache = cache,
    sigma.correction = sigma.correction,
    na.zero = na.zero
  )

  SC
}

# logl - no cache
lav_bvmix_logl <- function(Y1, Y2, eXo = NULL, wt = NULL,
                           rho = NULL,
                           fit.y1 = NULL, fit.y2 = NULL,
                           evar.y1 = NULL, beta.y1 = NULL,
                           th.y2 = NULL, sl.y2 = NULL) {
  if (is.null(fit.y1)) {
    fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt)
  }
  if (is.null(fit.y2)) {
    fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt)
  }

  # update z1/z2 if needed (used in lav_pml_dploglik_dimplied() in lav_model_gradient_pml.R)
  fit.y1 <- lav_uvreg_update_fit(
    fit.y = fit.y1, evar.new = evar.y1,
    beta.new = beta.y1
  )
  fit.y2 <- lav_uvord_update_fit(
    fit.y = fit.y2, th.new = th.y2,
    sl.new = sl.y2
  )

  # create cache environment
  cache <- lav_bvmix_init_cache(
    fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt,
    scores = TRUE
  )
  cache$theta <- rho

  lav_bvmix_logl_cache(cache = cache)
}

# lik - no cache
lav_bvmix_lik <- function(Y1, Y2, eXo = NULL, wt = NULL,
                          rho = NULL,
                          fit.y1 = NULL, fit.y2 = NULL,
                          evar.y1 = NULL, beta.y1 = NULL,
                          th.y2 = NULL, sl.y2 = NULL,
                          .log = FALSE) {
  if (is.null(fit.y1)) {
    fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt)
  }
  if (is.null(fit.y2)) {
    fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt)
  }

  # update z1/z2 if needed (used in lav_pml_dploglik_dimplied() in lav_model_gradient_pml.R)
  fit.y1 <- lav_uvreg_update_fit(
    fit.y = fit.y1, evar.new = evar.y1,
    beta.new = beta.y1
  )
  fit.y2 <- lav_uvord_update_fit(
    fit.y = fit.y2, th.new = th.y2,
    sl.new = sl.y2
  )

  # create cache environment
  cache <- lav_bvmix_init_cache(
    fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt,
    scores = TRUE
  )
  cache$theta <- rho

  lik <- lav_bvmix_lik_cache(cache = cache) # unweighted
  if (.log) {
    lik <- log(lik)
  }

  if (!is.null(wt)) {
    if (.log) {
      lik <- wt * lik
    } else {
      tmp <- wt * log(lik)
      lik <- exp(tmp)
    }
  }

  lik
}

# lav_model utility functions

# initial version: YR 25/03/2009: `methods' for the Model class
# - YR 14 Jan 2014: rename object -> lavmodel, all functions as lav_model_*
# - YR 20 Nov 2021: add lav_model_dmmdpar

lav_model_get_parameters <- function(lavmodel = NULL, GLIST = NULL,
                                     type = "free", extra = TRUE) {
  # type == "free": only non-redundant free parameters (x)
  # type == "user": all parameters listed in User model

  # state or final?
  if (is.null(GLIST)) GLIST <- lavmodel@GLIST # if this changes, tag @TDJorgensen in commit message

  if (type == "free") {
    N <- lavmodel@nx.free
    # } else if(type == "unco") {
    #    N <- lavmodel@nx.unco
  } else if (type == "user") {
    N <- lavmodel@nx.user
  }
  x <- numeric(N)

  for (mm in 1:length(lavmodel@GLIST)) {
    if (type == "free") {
      m.idx <- lavmodel@m.free.idx[[mm]]
      x.idx <- lavmodel@x.free.idx[[mm]]
      # } else if(type == "unco") {
      #    m.idx <- lavmodel@m.unco.idx[[mm]]
      #    x.idx <- lavmodel@x.unco.idx[[mm]]
    } else if (type == "user") {
      m.idx <- lavmodel@m.user.idx[[mm]]
      x.idx <- lavmodel@x.user.idx[[mm]]
    }
    x[x.idx] <- GLIST[[mm]][m.idx]
  }

  if (type == "user" && extra && sum(
    lavmodel@x.def.idx,
    lavmodel@x.ceq.idx,
    lavmodel@x.cin.idx
  ) > 0L) {
    # we need 'free' x
    x.free <- lav_model_get_parameters(
      lavmodel = lavmodel, GLIST = GLIST,
      type = "free"
    )
    if (length(lavmodel@x.def.idx) > 0L) {
      x[lavmodel@x.def.idx] <- lavmodel@def.function(x.free)
    }
    if (length(lavmodel@x.ceq.idx) > 0L) {
      x[lavmodel@x.ceq.idx] <- lavmodel@ceq.function(x.free)
    }
    if (length(lavmodel@x.cin.idx) > 0L) {
      tmp <- lavmodel@cin.function(x.free)
      # remove lower/upper bound values (if any)
      bound.idx <- attr(tmp, "bound.idx")
      if (length(bound.idx) > 0L) {
        tmp <- tmp[-bound.idx]
      }
      x[lavmodel@x.cin.idx] <- tmp
    }
  }

  x
}

# warning: this will make a copy of lavmodel
# warning: if categorical/correlation: 'delta' parameterization does
#          not work properly if we have 'mediators' (where x is not fixed)
#          that are observed (residuals are in PSI, and are not additive)
#          Note: fixed in 0.6-20 for recursive models
lav_model_set_parameters <- function(lavmodel = NULL, x = NULL) {
  tmp <- lavmodel@GLIST
  for (mm in 1:length(lavmodel@GLIST)) {
    m.free.idx <- lavmodel@m.free.idx[[mm]]
    x.free.idx <- lavmodel@x.free.idx[[mm]]
    tmp[[mm]][m.free.idx] <- x[x.free.idx]
  }

  correlation <- lavmodel@correlation

  # categorical? set categorical theta elements (if any)
  if (lavmodel@categorical || correlation) {
    nmat <- lavmodel@nmat
    if (lavmodel@representation == "LISREL") {
      for (g in 1:lavmodel@nblocks) {
        # which mm belong to group g?
        mm.in.group <- 1:nmat[g] + cumsum(c(0L, nmat))[g]

        if (lavmodel@estimator %in% c(
          "ML", "WLS", "GLS", "DWLS", "ULS", "PML",
          "catML"
        )) {
          if (lavmodel@parameterization == "delta") {
            tmp[mm.in.group] <-
              lav_lisrel_residual_variances(
                MLIST = tmp[mm.in.group],
                num.idx = lavmodel@num.idx[[g]],
                ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
                ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]]
              )
          } else if (lavmodel@parameterization == "theta") {
            tmp[mm.in.group] <-
              lav_lisrel_delta(
                MLIST = tmp[mm.in.group],
                num.idx = lavmodel@num.idx[[g]]
              )
          }
        } else if (lavmodel@estimator %in% c("MML", "FML")) {
          #  ttt <- diag(tmp[mm.in.group]$theta)
          #  diag(tmp[mm.in.group]$theta) <- as.numeric(NA)
          #  if(length(lavmodel@num.idx[[g]]) > 0L) {
          #      diag(tmp[mm.in.group]$theta)[ lavmodel@num.idx[[g]] ] <-
          #          ttt[ lavmodel@num.idx[[g]] ]
          #  }
        }
      }
    } else {
      cat("FIXME: deal with theta elements in the categorical case (RAM)")
    }
  }

  if (lavmodel@composites) {
  # for package stdmod only! (vignette stdmod_lavaan uses old fit object)
  #if (.hasSlot(lavmodel, "composites") && lavmodel@composites) {
    nmat <- lavmodel@nmat
    if (lavmodel@representation == "LISREL") {
      for (g in 1:lavmodel@nblocks) {
        # which mm belong to group g?
        mm.in.group <- 1:nmat[g] + cumsum(c(0L, nmat))[g]

        tmp[mm.in.group] <-
          lav_lisrel_composites_variances(MLIST = tmp[mm.in.group])
      }
    } else {
      cat("FIXME: deal with Composites if representation = RAM")
    }
  }

  lavmodel@GLIST <- tmp

  lavmodel
}

# create a standalone GLIST, filled with (new) x values
# (avoiding a copy of lavmodel)
lav_model_x2glist <- function(lavmodel = NULL, x = NULL,
                              type = "free", setDelta = TRUE,
                              m.el.idx = NULL, x.el.idx = NULL) {
  correlation <- lavmodel@correlation

  GLIST <- lavmodel@GLIST
  for (mm in 1:length(GLIST)) {
    # skip empty matrix
    if (nrow(GLIST[[mm]]) == 0L) {
      next
    }
    if (type == "free") {
      M.EL.IDX <- lavmodel@m.free.idx[[mm]]
      X.EL.IDX <- lavmodel@x.free.idx[[mm]]
    } else if (type == "unco") {
      M.EL.IDX <- lavmodel@m.free.idx[[mm]]
      X.EL.IDX <- lavmodel@x.unco.idx[[mm]]
    } else if (type == "full") {
      if (lavmodel@isSymmetric[mm]) {
        N <- ncol(GLIST[[mm]])
        M.EL.IDX <- lav_matrix_vech_idx(N)
      } else {
        M.EL.IDX <- seq_len(length(GLIST[[mm]]))
      }
      X.EL.IDX <- seq_len(length(m.el.idx))
      if (mm > 1) X.EL.IDX <- X.EL.IDX + sum(lavmodel@mmSize[1:(mm - 1)])
    } else if (type == "custom") {
      # nothing to do, m.el.idx and x.el.idx should be given
      M.EL.IDX <- m.el.idx[[mm]]
      X.EL.IDX <- x.el.idx[[mm]]
    }

    # assign
    GLIST[[mm]][M.EL.IDX] <- x[X.EL.IDX]

    # make symmetric (if full)
    if (type == "full" && lavmodel@isSymmetric[mm]) {
      T <- t(GLIST[[mm]])
      GLIST[[mm]][upper.tri(GLIST[[mm]])] <- T[upper.tri(T)]
    }
  }

  #    # theta parameterization: delta must be reset!
  #    if((lavmodel@categorical || correlation) && setDelta &&
  #       lavmodel@parameterization == "theta") {
  #        nmat <- lavmodel@nmat
  #        for(g in 1:lavmodel@nblocks) {
  #            # which mm belong to group g?
  #            mm.in.group <- 1:nmat[g] + cumsum(c(0L,nmat))[g]
  #            GLIST[mm.in.group] <-
  #                lav_lisrel_delta(MLIST = GLIST[mm.in.group],
  #                    num.idx = lavmodel@num.idx[[g]])
  #        }
  #    }

  # in 0.6-13: we always set theta/delta
  if ((lavmodel@categorical || correlation) && setDelta) {
    nmat <- lavmodel@nmat
    if (lavmodel@representation == "LISREL") {
      for (g in 1:lavmodel@nblocks) {
        # which mm belong to group g?
        mm.in.group <- 1:nmat[g] + cumsum(c(0L, nmat))[g]

        if (lavmodel@parameterization == "delta") {
          GLIST[mm.in.group] <-
            lav_lisrel_residual_variances(
              MLIST = GLIST[mm.in.group],
              num.idx = lavmodel@num.idx[[g]],
              ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
              ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]]
            )
        } else if (lavmodel@parameterization == "theta") {
          GLIST[mm.in.group] <-
            lav_lisrel_delta(
              MLIST = GLIST[mm.in.group],
              num.idx = lavmodel@num.idx[[g]]
            )
        }
      } # blocks
    } else {
      cat("FIXME: deal with theta elements in the categorical case (RAM)")
    }
  }

  if (lavmodel@composites) {
    nmat <- lavmodel@nmat
    if (lavmodel@representation == "LISREL") {
      for (g in 1:lavmodel@nblocks) {
        # which mm belong to group g?
        mm.in.group <- 1:nmat[g] + cumsum(c(0L, nmat))[g]

        GLIST[mm.in.group] <-
          lav_lisrel_composites_variances(MLIST = GLIST[mm.in.group])
      }
    } else {
      cat("FIXME: deal with Composites when representation = RAM")
    }
  }

  GLIST
}

# derivative of model matrix (say, Psi, Theta) wrt the free elements
# in that model matrix
# returns a matrix with 0/1 entries
# - rows are the nrow*ncol elements of the full matrix
# - cols are the free parameters
#
# TOdo: use sparse matrices
#
lav_model_dmmdpar <- function(lavmodel, target = "theta", group = 1L) {
  stopifnot(group <= lavmodel@ngroups)

  # MLIST for this group
  nmat <- lavmodel@nmat
  # which mm belong to group g?
  mm.in.group <- 1:nmat[group] + cumsum(c(0L, nmat))[group]
  MLIST <- lavmodel@GLIST[mm.in.group]

  # find target model matrix
  mlist.idx <- which(names(MLIST) == target)
  if (length(mlist.idx) == 0L) {
    lav_msg_stop(gettextf(
      "model matrix \"%s\" not found. Available model matrices are:", target),
      paste(names(MLIST), collapse = " "))
  }

  # target idx in GLIST
  target.idx <- cumsum(c(0L, nmat))[group] + mlist.idx

  # symmetric matrices (eg Psi, Theta)
  if (lavmodel@isSymmetric[[target.idx]]) {
    TARGET <- lavmodel@GLIST[[target.idx]]
    P <- nrow(TARGET)

    unique.idx <- unique(lavmodel@x.free.idx[[target.idx]])
    row.idx <- match(lavmodel@x.free.idx[[target.idx]], unique.idx)
    out <- matrix(0L, nrow = P * P, ncol = length(unique.idx))
    IDX <- cbind(lavmodel@m.free.idx[[target.idx]], row.idx)
    out[IDX] <- 1L

    # non-symmetric matrices (eg Lambda, Beta)
  } else {
    TARGET <- lavmodel@GLIST[[target.idx]]
    P <- nrow(TARGET)
    M <- ncol(TARGET)

    row.idx <- seq_len(length(lavmodel@x.free.idx[[target.idx]]))
    out <- matrix(0L, nrow = P * M, ncol = length(row.idx))
    IDX <- cbind(lavmodel@m.free.idx[[target.idx]], row.idx)
    out[IDX] <- 1L
  }

  out
}

# backwards compatibility
# getModelParameters <- lav_model_get_parameters
# setModelParameters <- lav_model_set_parameters
# x2GLIST            <- lav_model_x2glist

lav_lavaan_step00_parameters <- function(matchcall = NULL,
                                         syscall = NULL,
                                         dotdotdot = NULL) {
  # 1. resolve a problem where parameter 'cl' is matched to 'cluster'
  #    and shouldn't
  # 2. apply default options for cfa/sem/growth functions
  # 3. if dotdotdot$control present, copy to dotdotdot$... for
  #   optim.method,
  #   optim.force.converged,
  #   gradient -> optim.gradient !!! overwritten by dotdotdot$gradient
  #     if present
  #   init_nelder_mead -> optim.init_nelder_mead

  mc <- matchcall
  sc <- syscall
  ddd <- dotdotdot

  # catch partial matching of 'cl' (expanded to cluster)
  if (!is.null(sc[["cl"]]) &&
    is.null(sc[["cluster"]]) &&
    !is.null(mc[["cluster"]])) {
    mc[["cl"]] <- mc[["cluster"]]
    mc[["cluster"]] <- NULL
    ddd$cl <- sc[["cl"]]
  }
  if (!is.null(mc$cluster)) mc$cluster <- eval(mc$cluster, parent.frame(2))

  # default options
  if (any(ddd$model.type == c("sem", "cfa", "growth"))) {
    # default options for sem/cfa or growth
    defaults <- list(
      int.ov.free     = ddd$model.type != "growth",
      int.lv.free     = ddd$model.type == "growth",
      auto.fix.first  = TRUE, # (re)set in lav_options_set
      auto.fix.single = TRUE,
      auto.var        = TRUE,
      auto.cov.lv.x   = TRUE,
      auto.cov.y      = TRUE,
      auto.th         = TRUE,
      auto.delta      = TRUE,
      auto.efa        = TRUE
    )
    for (dflt.i in seq_along(defaults)) {
      argname <- names(defaults)[dflt.i]
      if (is.null(mc[[argname]])) {
        mc[[argname]] <- defaults[[dflt.i]]
        ddd[[argname]] <- defaults[[dflt.i]]
      }
    }
  }

  # backwards compatibility, control= argument (<0.5-23)
  if (!is.null(ddd$control)) {
    # optim.method
    if (!is.null(ddd$control$optim.method)) {
      ddd$optim.method <- ddd$control$optim.method
    }
    # cor.optim.method
    if (!is.null(ddd$control$cor.optim.method)) {
      # ignore it silently
    }
    # control$optim.force.converged
    if (!is.null(ddd$control$optim.force.converged)) {
      ddd$optim.force.converged <- ddd$control$optim.force.converged
    }
    # gradient
    if (!is.null(ddd$control$gradient)) {
      ddd$optim.gradient <- ddd$control$gradient
    }
    if (!is.null(ddd$gradient)) {
      ddd$optim.gradient <- ddd$gradient
    }
    # init_nelder_mead
    if (!is.null(ddd$control$init_nelder_mead)) {
      ddd$optim.init_nelder_mead <- ddd$control$init_nelder_mead
    }
  }

  list(mc = mc, dotdotdot = ddd)
}

lav_lavaan_step00_checkdata <- function(data = NULL,
                                        dotdotdot = NULL,
                                        sample.cov = NULL,
                                        sample.nobs = NULL,
                                        sample.mean = NULL,
                                        sample.th = NULL,
                                        NACOV = NULL, # nolint
                                        WLS.V = NULL, # nolint
                                        ov.order = NULL) {
  # if data not NULL:
  #   if it is an 'enriched' data.frame (e.g. a tibble), simplify to an
  #   ordinary data.frame
  #   if class is 'lavMoments':
  #         check if it contains sample.cov and sample.nobs (***error*** if not)
  #         if sample.mean, sample.th, NACOV and/or WLS.V present,
  #                   copy to corresponding arguments of the function
  #         if lavOptions present in data, copy those that are not provided
  #         in the function call to dotdotdot$...
  #             set data to NULL
  #   if it is a function --> ***error***
  #   TODO: other tests are present in lav_lavdata(), should we copy them here ???
  # if NACOV or WLS.V not NULL, set ov.order to "data"

  if (!is.null(data)) {
    if (inherits(data, "data.frame")) {
      # just in case it is not a traditional data.frame
      data <- as.data.frame(data)
    } else if (inherits(data, "lavMoments")) {
      # This object must contain summary statistics
      # e.g., created by lavaan.mi::poolSat

      # set required-data arguments
      if ("sample.cov" %in% names(data)) {
        sample.cov <- data$sample.cov
      } else {
        lav_msg_stop(gettext(
          "When data= is of class lavMoments, it must contain sample.cov"))
      }

      if ("sample.nobs" %in% names(data)) {
        sample.nobs <- data$sample.nobs
      } else {
        lav_msg_stop(gettext(
          "When data= is of class lavMoments, it must contain sample.nobs"))
      }

      # check for optional-data arguments
      if ("sample.mean" %in% names(data)) sample.mean <- data$sample.mean
      if ("sample.th" %in% names(data)) sample.th <- data$sample.th
      if ("NACOV" %in% names(data)) NACOV <- data$NACOV # nolint
      if ("WLS.V" %in% names(data)) WLS.V <- data$WLS.V # nolint

      # set other args not included in dotdotdot
      if (length(data$lavOptions)) {
        newdots <- setdiff(names(data$lavOptions), names(dotdotdot))
        if (length(newdots)) {
          for (dd in newdots) dotdotdot[[dd]] <- data$lavOptions[[dd]]
        }
      }

      # FIXME: Should WLS.V be an I(dentity) matrix when ULS is requested?
      #       Unused for point estimates, but still used to scale/shift test
      # if (!is.null(dotdotdot$estimator)) {
      #   if (grepl(pattern = "ULS", x = toupper(dotdotdot$estimator[1L])) &&
      #       !is.null(WLS.V)) {
      #     #  set to diagonal
      #     if (is.list(WLS.V)) {
      #       WLS.V <- lapply(WLS.V, function(w) {diag(w) <- 1 ; return(w) })
      #     } else diag(WLS.V) <- 1
      #   }
      # }

      # get rid of data= argument
      data <- NULL
    }

    if (is.function(data)) {
      lav_msg_stop(gettext("data is a function; it should be a data.frame"))
    }
  }
  # new in 0.6-14: if NACOV and/or WLS.V are provided, we force
  # ov.order="data" for now
  # until we have reliable code to re-arrange/select col/rows for
  # of NACOV/WLS.V based on the model-based ov.names
  if (!is.null(NACOV) || !is.null(WLS.V)) {
    if (ov.order != "force.model") { # used by sam()
      ov.order <- "data"
    } else {
      ov.order <- "model"
    }
  }

  list(
    data = data, dotdotdot = dotdotdot, sample.cov = sample.cov,
    sample.nobs = sample.nobs, sample.mean = sample.mean,
    sample.th = sample.th, NACOV = NACOV, WLS.V = WLS.V, ov.order = ov.order
  )
}

# this function is written by Myrsini Katsikatsou

############################## pairwiseTables FUNCTION ########################
# This function can be public. It gets as an input a raw data set of ordinal
# variables and it returns a list of all pairwise frequency tables.
#
# The input arguments of the function:
# data : matrix or data frame containing the data. The rows correspond to
#       different observations and the columns to different observed categorical
#       (ordinal or nominal) variables. No continuous variables or covariates
#       should be contained in data. If the variables contained in the data are
#       distinguished into indicators of exogenous latent variables (lv) and
#       indicators of endogenous latent variables, those for exogenous lv should
#       be presented first (in the first columns of data) followed by the
#       indicators for endogenous lv.
# var.levels: NULL or vector or list, specifies the levels (response categories)
#            for each categorical variable contained in data.
#            If NULL, the levels encoutered in data are used. If a response
#            category is not observed in the data, then var.levels should be
#            defined.
#            If vector, that implies that all variables have the same levels as
#            given in the vector.
#            If list, the components of the list are vectors, as many as the
#            number of variables in data. Each vector gives the levels of
#            the corresponding categorical variable in data.
# no.x : NULL or integer, gives the number of indicators for exogenous lv.
#        The default value is NULL indicating that data contains only
#        indicators of exogenous latent variables.
# perc : TRUE/FALSE. If FALSE the observed frequencies are reported, otherwise
#        the observed percentages are given.
# na.exclude : TRUE/FALSE. If TRUE, listwise deletion is applied to data.
#              Otherwise, cases with missing values are preserved and and an
#              extra level with label NA is included in the tables.

# The output of the function:
# It is a list of three components: $pairTables, $VarLevels and $Ncases_del.
# pairTables : a list of so many tables as the number of variable pairs formed
#              by data. If there are indicators of both exogenous and endogenous
#              variables, then first all the matrices referring to pairs of
#              indicators of exogenous lv are reported, followed by all the
#              matrices referring to pairs of indicators of endogenous lv, which
#              in turn folowed by all the matrices of pairs: one indicator of an
#              exogenous - one indicator of an endogenous lv.
# VarLevels : a list of as many vectors as the number of variables in the data.
#             Each vector gives the levels/ response categories of each variable
# Ncases_del : An integer reporting the number of cases deleted by data because
#              of missing values (listwise deletion) when na.exclude=TRUE.



pairwiseTables <- function(data, var.levels = NULL, no.x = NULL,
                           perc = FALSE, na.exclude = TRUE) {
  # data in right format?
  if ((!is.matrix(data)) & (!is.data.frame(data))) {
    lav_msg_stop(gettext("data is neither a matrix nor a data.frame"))
  }

  # at least two variables
  no.var <- dim(data)[2]
  if (no.var < 2) {
    lav_msg_stop(gettext("there are less than 2 variables"))
  }

  # no.x < no.var  ?
  if (no.x > no.var) {
    lav_msg_stop(gettext(
      "number of indicators for exogenous latent variables is larger than
      the total number of variables in data"))
  }


  # if data as matrix, transforma as data.frame
  if (is.matrix(data)) {
    data <- as.data.frame(data)
  }

  # listwise deletion
  if (na.exclude) {
    old.data <- data
    data <- na.omit(data)
  }

  # all columns of data.frame should be of class factor so that function levels
  # can be applied
  if (!all(sapply(data, class) == "factor")) {
    if (nrow(data) > 1) {
      data <- data.frame(sapply(data, factor))
    } else {
      data <- apply(data, 2, factor)
      data <- as.data.frame(matrix(data, nrow = 1))
    }
  }

  # the levels observed for each variable, obs.levels is a list
  obs.levels <- lapply(data, levels)

  # number of variables in data same as number of vectors in var.levels
  if (is.list(var.levels) && no.var != length(var.levels)) {
    lav_msg_stop(gettext(
      "the length of var.levels does not match the number of variables of
      the given data set"))
  }

  # create var.levels if a list is not given
  old.var.levels <- var.levels
  if (!is.list(old.var.levels)) {
    if (is.null(old.var.levels)) {
      var.levels <- obs.levels
    } else {
      var.levels <- vector("list", no.var)
      var.levels <- lapply(var.levels, function(x) {
        x <- old.var.levels
      })
    }
  }
  names(var.levels) <- names(data)

  # also check that obs.levels exist in the object var.levels given by the user, i.e. old.var.levels
  if (is.list(old.var.levels)) {
    for (i in 1:no.var) {
      if (!all(obs.levels[[i]] %in% old.var.levels[[i]])) {
        lav_msg_stop(gettext(
          "levels observed in data are not mentioned in var.levels"))
      }
    }
  } else if (is.vector(old.var.levels)) {
    if (!all(apply(na.omit(data), 2, function(x) {
      x %in% old.var.levels
    }))) {
      lav_msg_stop(gettext("levels observed in data are not mentioned
                           in var.levels"))
    }
  }

  no.given.levels <- sapply(var.levels, length)

  # assign the right levels for each variable as given in object var.levels if it is not the case
  # it is not the case when the observed levels are a subgroup of the var.levels given
  if (!is.null(old.var.levels)) {
    no.obs.levels <- sapply(obs.levels, length)
    if (!all(no.obs.levels == no.given.levels)) {
      index <- c(1:no.var)[no.obs.levels != no.given.levels]
      for (i in index) {
        data[, i] <- factor(data[, i], levels = var.levels[[i]])
      }
    }
  }

  # compute the bivariate frequency tables
  # Split first into two cases: a) only indicators of exogenous latent variables
  # b) otherwise
  if (is.null(no.x) || no.x == no.var) {
    pairs.index <- utils::combn(no.var, 2)
    no.pairs <- dim(pairs.index)[2]
    res <- vector("list", no.pairs)
    for (i in 1:no.pairs) {
      res[[i]] <- table(data[, pairs.index[, i]], useNA = "ifany")
    }
  } else {
    no.y <- no.var - no.x
    pairs.xixj.index <- utils::combn(no.x, 2) # row 1 gives i index, row 2 j index, j runs faster than i
    pairs.yiyj.index <- utils::combn(no.y, 2)
    pairs.xiyj.index <- expand.grid(1:no.y, 1:no.x)
    pairs.xiyj.index <- rbind(pairs.xiyj.index[, 2], pairs.xiyj.index[, 1]) # row 1 gives i index, row 2 j index, j runs faster than i

    no.pairs.xixj <- dim(pairs.xixj.index)[2]
    no.pairs.yiyj <- dim(pairs.yiyj.index)[2]
    no.pairs.xiyj <- dim(pairs.xiyj.index)[2]
    no.all.pairs <- no.pairs.xixj + no.pairs.yiyj + no.pairs.xiyj

    data.x <- data[, 1:no.x]
    data.y <- data[, (no.x + 1):no.var]

    res <- vector("list", no.all.pairs)
    for (i in 1:no.pairs.xixj) {
      res[[i]] <- table(data.x[, pairs.xixj.index[, i]], useNA = "ifany")
    }

    j <- 0
    for (i in (no.pairs.xixj + 1):(no.pairs.xixj + no.pairs.yiyj)) {
      j <- j + 1
      res[[i]] <- table(data.y[, pairs.yiyj.index[, j]], useNA = "ifany")
    }

    j <- 0
    for (i in (no.pairs.xixj + no.pairs.yiyj + 1):no.all.pairs) {
      j <- j + 1
      res[[i]] <- table(
        cbind(
          data.x[, pairs.xiyj.index[1, j], drop = FALSE],
          data.y[, pairs.xiyj.index[2, j], drop = FALSE]
        ),
        useNA = "ifany"
      )
    }
  }

  # if percentages are asked
  if (perc) {
    Nobs <- dim(data)[1]
    res <- lapply(res, function(x) {
      x / Nobs
    })
  }

  # Ncases_del = the number of cases deleted because they had missing values
  if (na.exclude) {
    Ncases_deleted <- dim(old.data)[1] - dim(data)[1]
  } else {
    Ncases_deleted <- 0
  }

  list(pairTables = res, VarLevels = var.levels, Ncases_del = Ncases_deleted)
}

# casewise likelihoods

# closed-form marginal likelihood
# - classic SEM models, continous observed variables only
lav_model_lik_ml <- function(lavmodel = NULL,
                             GLIST = NULL,
                             lavdata = NULL,
                             lavsamplestats = NULL) {


}


# marginal ML
lav_model_lik_mml <- function(lavmodel = NULL,
                              THETA = NULL,
                              TH = NULL,
                              GLIST = NULL,
                              group = 1L,
                              lavdata = NULL,
                              sample.mean = NULL,
                              sample.mean.x = NULL,
                              lavcache = NULL) {
  conditional.x <- lavmodel@conditional.x

  # data for this group
  X <- lavdata@X[[group]]
  nobs <- nrow(X)
  nvar <- ncol(X)
  eXo <- lavdata@eXo[[group]]

  # MLIST (for veta and yhat)
  mm.in.group <- 1:lavmodel@nmat[group] + cumsum(c(0, lavmodel@nmat))[group]
  MLIST <- GLIST[mm.in.group]

  # quadrature points
  GH <- lavcache[[group]]$GH
  nGH <- nrow(GH$x)
  nfac <- ncol(GH$x)

  # compute VETAx (latent lv only)
  lv.dummy.idx <- c(
    lavmodel@ov.y.dummy.lv.idx[[group]],
    lavmodel@ov.x.dummy.lv.idx[[group]]
  )
  VETAx <- lav_lisrel_vetax(
    MLIST = MLIST,
    lv.dummy.idx = lv.dummy.idx
  )
  # VETAx <- lav_lisrel_vetax(MLIST = MLIST)
  # check for negative values?
  if (any(diag(VETAx) < 0)) {
    lav_msg_warn(gettext("--- VETAx contains negative values"))
    print(VETAx)
    return(0)
  }

  # cholesky?
  # if(is.null(lavmodel@control$cholesky)) {
  CHOLESKY <- TRUE
  # } else {
  #    CHOLESKY <- as.logical(lavmodel@control$cholesky)
  # if(nfac > 1L && !CHOLESKY) {
  #    warning("lavaan WARNING: CHOLESKY is OFF but nfac > 1L")
  # }
  # }

  if (!CHOLESKY) {
    # we should still 'scale' the factors, if std.lv=FALSE
    ETA.sd <- sqrt(diag(VETAx))
  } else {
    # cholesky takes care of scaling
    tchol.VETA <- try(chol(VETAx), silent = TRUE)
    if (inherits(tchol.VETA, "try-error")) {
      lav_msg_warn(gettext("--- VETAx not positive definite"))
      print(VETAx)
      return(0)
    }
    if (!is.null(MLIST$alpha) || !is.null(MLIST$gamma)) {
      if (conditional.x) {
        EETAx <- lav_lisrel_eetax(
          MLIST = MLIST, eXo = eXo, N = nobs,
          sample.mean = sample.mean,
          ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[group]],
          ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[group]],
          ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[group]],
          ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[group]]
        )
      } else {
        EETA <- lav_lisrel_eeta(
          MLIST = MLIST,
          mean.x = sample.mean.x,
          sample.mean = sample.mean,
          ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[group]],
          ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[group]],
          ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[group]],
          ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[group]]
        )
      }
      # if(length(lv.dummy.idx) > 0L) {
      #    EETAx <- EETAx[,-lv.dummy.idx,drop=FALSE]
      # }
    }
  }

  # compute (log)lik for each node, for each observation
  SUM.LOG.FY <- matrix(0, nrow = nGH, ncol = nobs)
  for (q in 1:nGH) {
    # current value(s) for ETA
    # eta <- matrix(0, nrow = 1, ncol = ncol(MLIST$lambda))

    # non-dummy elements -> quadrature points
    # eta[1L, -lv.dummy.idx] <- GH$x[q,,drop=FALSE]
    XQ <- GH$x[q, , drop = FALSE]

    # rescale/unwhiten
    if (CHOLESKY) {
      # un-orthogonalize
      XQ <- XQ %*% tchol.VETA
    } else {
      # no unit scale? (un-standardize)
      XQ <- sweep(XQ, MARGIN = 2, STATS = ETA.sd, FUN = "*")
    }

    eta <- matrix(0, nrow = 1, ncol = ncol(MLIST$lambda))
    if (length(lv.dummy.idx) > 0L) {
      eta[, -lv.dummy.idx] <- XQ
    } else {
      eta <- XQ
    }

    # eta_i = alpha + BETA eta_i + GAMMA eta_i + error
    #
    # - direct effect of BETA is already in VETAx, and hence tchol.VETA
    # - need to add alpha, and GAMMA eta_i
    if (!is.null(MLIST$alpha) || !is.null(MLIST$gamma)) {
      if (conditional.x) {
        eta <- sweep(EETAx, MARGIN = 2, STATS = eta, FUN = "+")
      } else {
        eta <- eta + EETA
      }
    }

    # compute yhat for this node (eta)
    if (lavmodel@conditional.x) {
      yhat <- lav_lisrel_eyetax(
        MLIST = MLIST, eXo = eXo,
        ETA = eta, sample.mean = sample.mean,
        ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[group]],
        ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[group]],
        ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[group]],
        ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[group]]
      )
    } else {
      yhat <- lav_lisrel_eyetax3(
        MLIST = MLIST,
        ETA = eta, sample.mean = sample.mean,
        mean.x = sample.mean.x,
        ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[group]],
        ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[group]],
        ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[group]],
        ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[group]]
      )
    }

    # compute fy.var, for this node (eta): P(Y_i =  y_i | eta_i, x_i)
    log.fy.var <- lav_predict_fy_internal(
      X = X, yhat = yhat,
      TH = TH, THETA = THETA,
      num.idx = lavmodel@num.idx[[group]],
      th.idx = lavmodel@th.idx[[group]],
      link = lavmodel@link, log. = TRUE
    )

    # if log, fy is just the sum of log.fy.var
    log.fy <- apply(log.fy.var, 1L, sum)

    # store log likelihoods for this node
    SUM.LOG.FY[q, ] <- log.fy
  }

  # integration
  lik <- as.numeric(t(GH$w) %*% exp(SUM.LOG.FY))

  # avoid underflow
  idx <- which(lik < exp(-600))
  if (length(idx) > 0L) {
    lik[idx] <- exp(-600)
  }

  lik
}

# generate syntax for an independence model
lav_syntax_independence <- function(ov.names = character(0),
                                    ov.names.x = character(0),
                                    sample.cov = NULL) {
  ov.names.nox <- ov.names[!ov.names %in% ov.names.x]
  nvar <- length(ov.names.nox)
  lv.names <- paste("f", 1:nvar, sep = "")

  # check sample.cov
  if (!is.null(sample.cov)) {
    if (is.list(sample.cov)) {
      ngroups <- length(sample.cov)
    } else {
      ngroups <- 1L
      sample.cov <- list(sample.cov)
    }
    stopifnot(is.matrix(sample.cov[[1]]))
    # stopifnot(length(ov.names) == nrow(sample.cov[[1]]))
    # FIXME: check rownames and reorder...
  }

  # construct lavaan syntax for an independence model
  txt <- "# independence model\n"

  # =~ lines (each observed variables has its own latent variable)
  # excepct for ov's that are in ov.names.x
  txt <- paste(txt, paste(lv.names, " =~ 1*", ov.names.nox,
    "\n",
    sep = "", collapse = ""
  ), sep = "")

  # residual ov variances fixed to zero
  txt <- paste(txt, paste(ov.names.nox, " ~~ 0*", ov.names.nox,
    "\n",
    sep = "", collapse = ""
  ), sep = "")

  # latent variances
  if (is.null(sample.cov)) {
    txt <- paste(txt, paste(lv.names, " ~~ ", lv.names,
      "\n",
      sep = "", collapse = ""
    ), sep = "")
  } else {
    # fill in sample values
    ov.idx <- match(ov.names.nox, ov.names)

    start.txt <- paste("start(c(",
      apply(matrix(
        unlist(lapply(sample.cov, function(x) {
          diag(x)[ov.idx]
        })),
        ncol = ngroups
      ), 1, paste, collapse = ","), "))",
      sep = ""
    )
    txt <- paste(txt, paste(lv.names, " ~~ ", start.txt, " * ",
      lv.names,
      "\n",
      sep = "", collapse = ""
    ), sep = "")
  }

  # latent *covariances* fixed to zero (= independence!)
  if (length(lv.names) > 1L) {
    tmp <- utils::combn(lv.names, 2)
    txt <- paste(txt, paste(tmp[1, ], " ~~ 0*", tmp[2, ], "\n",
      sep = "",
      collapse = ""
    ), sep = "")
  }

  # if 'independent x' variables, add an 'empty' regression
  if ((nx <- length(ov.names.x)) > 0) {
    # dummy regression line
    txt <- paste(txt, paste("f1 ~ 0*", ov.names.x,
      "\n",
      sep = "", collapse = ""
    ), sep = "")
  }

  # Note: no need to pass starting values here, lavaanStart will
  # use the sample statistics anyway....

  txt
}

lav_standardize_lv_x <- function(x, lavobject, partable = NULL, cov.std = TRUE,
                                 lv.var = NULL,
                                 rotation = FALSE) {
  # set new values for x
  lavmodel <- lav_model_set_parameters(lavmodel = lavobject@Model, x = x)

  if (rotation) {
    x.unrotated <- x
    lavmodel@GLIST <- lavTech(lavobject, "est.unrotated") # unrotated!
    est.rot <- lav_model_efa_rotate_x(
      x = x.unrotated,
      lavmodel = lavmodel, # unrotated!
      lavoptions = lavobject@Options,
      init.rot = lavmodel@H,
      type = "user",
      extra = TRUE
    )
    GLIST <- attr(est.rot, "extra")$GLIST
    attributes(est.rot) <- NULL
    est <- est.rot
  } else {
    GLIST <- lavmodel@GLIST # if this changes, tag @TDJorgensen in commit message
    est <- lav_model_get_parameters(lavmodel, type = "user")
  }

  x.stand.user <- lav_standardize_lv(
    lavobject = lavobject,
    partable = partable, est = est,
    GLIST = GLIST, cov.std = cov.std,
    lv.var = lv.var
  )

  x.stand.user
}

lav_standardize_all_x <- function(x, lavobject, partable = NULL, cov.std = TRUE,
                                  rotation = FALSE) {
  lavmodel <- lav_model_set_parameters(lavmodel = lavobject@Model, x = x)

  if (rotation) {
    x.unrotated <- x
    lavmodel@GLIST <- lavTech(lavobject, "est.unrotated") # unrotated!
    est.rot <- lav_model_efa_rotate_x(
      x = x.unrotated,
      lavmodel = lavmodel, # unrotated!
      lavoptions = lavobject@Options,
      init.rot = lavmodel@H,
      type = "user",
      extra = TRUE
    )
    GLIST <- attr(est.rot, "extra")$GLIST
    attributes(est.rot) <- NULL
    est <- est.rot
  } else {
    GLIST <- lavmodel@GLIST # if this changes, tag @TDJorgensen in commit message
    est <- lav_model_get_parameters(lavmodel, type = "user")
  }

  x.stand.user <- lav_standardize_all(
    lavobject = lavobject,
    partable = partable, est = est,
    est.std = NULL, GLIST = GLIST,
    cov.std = cov.std
  )
  x.stand.user
}

lav_standardize_all_nox_x <- function(x, lavobject, partable = NULL,
                                      cov.std = TRUE, rotation = FALSE) {
  lavmodel <- lav_model_set_parameters(lavmodel = lavobject@Model, x = x)

  if (rotation) {
    x.unrotated <- x
    lavmodel@GLIST <- lavTech(lavobject, "est.unrotated") # unrotated!
    est.rot <- lav_model_efa_rotate_x(
      x = x.unrotated,
      lavmodel = lavmodel, # unrotated!
      lavoptions = lavobject@Options,
      init.rot = lavmodel@H,
      type = "user",
      extra = TRUE
    )
    GLIST <- attr(est.rot, "extra")$GLIST
    attributes(est.rot) <- NULL
    est <- est.rot
  } else {
    GLIST <- lavmodel@GLIST # if this changes, tag @TDJorgensen in commit message
    est <- lav_model_get_parameters(lavmodel, type = "user")
  }

  x.stand.user <- lav_standardize_all_nox(
    lavobject = lavobject,
    partable = partable, est = est,
    est.std = NULL, GLIST = GLIST,
    cov.std = cov.std
  )
  x.stand.user
}

lav_unstandardize_ov_x <- function(x, lavobject) {
  partable <- lavobject@ParTable
  partable$ustart <- x
  lav_unstandardize_ov(
    partable = partable,
    ov.var = lavobject@SampleStats@var,
    cov.std = TRUE
  )
}


lav_standardize_lv <- function(lavobject = NULL,
                               partable = NULL, est = NULL, GLIST = NULL,
                               cov.std = TRUE, lv.var = NULL,
                               lavmodel = NULL, lavpartable = NULL) {
  if (is.null(lavobject)) {
    stopifnot(!is.null(lavmodel))
    stopifnot(!is.null(lavpartable))
    if (is.null(est)) {
      if (!is.null(lavpartable$est)) {
        est <- lavpartable$est # if this changes, tag @TDJorgensen in commit message
      } else {
        lav_msg_stop(gettext("could not find `est' in lavpartable"))
      }
    }
  } else {
    lavmodel <- lavobject@Model
    lavpartable <- lavobject@ParTable
    if (is.null(est)) {
      est <- lav_object_inspect_est(lavobject)
    }
  }

  if (is.null(partable)) {
    partable <- lavpartable
  }
  if (is.null(GLIST)) {
    GLIST <- lavmodel@GLIST
  }

  out <- est
  N <- length(est)
  stopifnot(N == length(partable$lhs))

  nmat <- lavmodel@nmat

  # compute ETA
  if (is.null(lv.var)) {
    LV.ETA <- lav_model_veta(
      lavmodel = lavmodel,
      GLIST = GLIST
    )
  }

  for (g in 1:lavmodel@nblocks) {
    ov.names <- lav_partable_vnames(lavpartable, "ov", block = g) # not user,
    # which may be incomplete
    lv.names <- lav_partable_vnames(lavpartable, "lv", block = g)

    # shortcut: no latents in this block, nothing to do
    if (length(lv.names) == 0L) {
      next
    }

    # which mm belong to block g?
    mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
    MLIST <- GLIST[mm.in.group]

    if (is.null(lv.var)) {
      ETA2 <- diag(LV.ETA[[g]])
    } else {
      ETA2 <- lv.var[[g]]
    }
    # change negative values to NA
    ETA2[ETA2 < 0] <- as.numeric(NA)
    ETA <- sqrt(ETA2)

    # 1a. "=~" regular indicators
    idx <- which(partable$op == "=~" & !(partable$rhs %in% lv.names) &
      partable$block == g)
    out[idx] <- out[idx] * ETA[match(partable$lhs[idx], lv.names)]

    # 1b. "=~" regular higher-order lv indicators
    idx <- which(partable$op == "=~" & !(partable$rhs %in% ov.names) &
      partable$block == g)
    out[idx] <- (out[idx] * ETA[match(partable$lhs[idx], lv.names)]
      / ETA[match(partable$rhs[idx], lv.names)])

    # 1c. "=~" indicators that are both in ov and lv
    # idx <- which(partable$op == "=~" & partable$rhs %in% ov.names
    #                             & partable$rhs %in% lv.names &
    #             partable$block == g)

    # 2. "~" regressions (and "<~")
    idx <- which((partable$op == "~" | partable$op == "<~") &
      partable$lhs %in% lv.names &
      partable$block == g)
    out[idx] <- out[idx] / ETA[match(partable$lhs[idx], lv.names)]

    idx <- which((partable$op == "~" | partable$op == "<~") &
      partable$rhs %in% lv.names &
      partable$block == g)
    out[idx] <- out[idx] * ETA[match(partable$rhs[idx], lv.names)]

    # 3a. "~~" ov
    # idx <- which(partable$op == "~~" & !(partable$lhs %in% lv.names) &
    #             partable$block == g)

    # 3b. "~~" lv
    # ATTENTION: in Mplus 4.1, the off-diagonal residual covariances
    #            were computed by the formula cov(i,j) / sqrt(i.var*j.var)
    #            were i.var and j.var where diagonal elements of ETA
    #
    #            in Mplus 6.1 (but also AMOS and EQS), the i.var and j.var
    #            elements are the 'PSI' diagonal elements!!

    # variances
    rv.idx <- which(partable$op == "~~" & partable$rhs %in% lv.names &
      partable$lhs == partable$rhs &
      partable$block == g)
    out[rv.idx] <- (out[rv.idx] / ETA[match(partable$lhs[rv.idx], lv.names)]
      / ETA[match(partable$rhs[rv.idx], lv.names)])

    # covariances lv
    # three types:
    # - only lhs is LV (and fixed.x = FALSE)
    # - only rhs is LV (and fixed.x = FALSE)
    # - both lhs and rhs are LV (regular case)
    if (cov.std) {
      if (!is.complex(est[rv.idx])) {
        RV <- sqrt(abs(est[rv.idx])) # abs in case of heywood cases
      } else {
        RV <- sqrt(est[rv.idx])
      }
      rv.names <- partable$lhs[rv.idx]
    }

    # left
    idx.lhs <- which(partable$op == "~~" &
      partable$lhs %in% lv.names &
      partable$lhs != partable$rhs &
      partable$block == g)
    if (length(idx.lhs) > 0L) {
      if (cov.std == FALSE) {
        out[idx.lhs] <-
          (out[idx.lhs] / ETA[match(partable$lhs[idx.lhs], lv.names)])
      } else {
        out[idx.lhs] <-
          (out[idx.lhs] / RV[match(partable$lhs[idx.lhs], rv.names)])
      }
    }

    # right
    idx.rhs <- which(partable$op == "~~" &
      partable$rhs %in% lv.names &
      partable$lhs != partable$rhs &
      partable$block == g)
    if (length(idx.rhs) > 0L) {
      if (cov.std == FALSE) {
        out[idx.rhs] <-
          (out[idx.rhs] / ETA[match(partable$rhs[idx.rhs], lv.names)])
      } else {
        out[idx.rhs] <-
          (out[idx.rhs] / RV[match(partable$rhs[idx.rhs], rv.names)])
      }
    }


    # 4a. "~1" ov
    # idx <- which(partable$op == "~1" & !(partable$lhs %in% lv.names) &
    #             partable$block == g)

    # 4b. "~1" lv
    idx <- which(partable$op == "~1" & partable$lhs %in% lv.names &
      partable$block == g)
    out[idx] <- out[idx] / ETA[match(partable$lhs[idx], lv.names)]
  }

  # 5a ":="
  idx <- which(partable$op == ":=")
  if (length(idx) > 0L) {
    x <- out[partable$free & !duplicated(partable$free)]
    out[idx] <- lavmodel@def.function(x)
  }

  # 5b "=="
  idx <- which(partable$op == "==")
  if (length(idx) > 0L) {
    x <- out[partable$free & !duplicated(partable$free)]
    out[idx] <- lavmodel@ceq.function(x)
  }

  # 5c. "<" or ">"
  idx <- which((partable$op == "<" | partable$op == ">"))
  if (length(idx) > 0L) {
    x <- out[partable$free & !duplicated(partable$free)]
    out[idx] <- lavmodel@cin.function(x)
  }

  out
}

lav_standardize_all <- function(lavobject = NULL,
                                partable = NULL, est = NULL, est.std = NULL,
                                GLIST = NULL, cov.std = TRUE, ov.var = NULL,
                                lv.var = NULL,
                                lavmodel = NULL, lavpartable = NULL,
                                cov.x = NULL) {
  if (is.null(lavobject)) {
    stopifnot(!is.null(lavmodel))
    stopifnot(!is.null(lavpartable))
    if (is.null(est)) {
      if (!is.null(lavpartable$est)) {
        est <- lavpartable$est # if this changes, tag @TDJorgensen in commit message
      } else {
        lav_msg_stop(gettext("could not find `est' in lavpartable"))
      }
    }
  } else {
    lavmodel <- lavobject@Model
    lavpartable <- lavobject@ParTable
    if (is.null(est)) {
      est <- lav_object_inspect_est(lavobject)
    }
    if (lavmodel@conditional.x) {
      if (is.null(cov.x)) {
        # try SampleStats slot
        # if("SampleStats" %in% slotNames(lavobject)) {
        #    cov.x <- lavobject@SampleStats@cov.x
        if (!is.null(lavobject@implied$cov.x[[1]])) {
          cov.x <- lavobject@implied$cov.x # if this changes, tag @TDJorgensen in commit message
        } else {
          # perhaps lavaanList object
          # extract it from GLIST per block
          cov.x <- vector("list", length = lavmodel@nblocks)
          for (b in seq_len(lavmodel@nblocks)) {
            # which mm belong to block b?
            mm.in.block <- (seq_len(lavmodel@nmat[b]) +
              cumsum(c(0, lavmodel@nmat))[b])
            MLIST <- lavmodel@GLIST[mm.in.block]
            cov.x[[b]] <- MLIST[["cov.x"]]
          }
        }
      }
    }
  }

  if (is.null(partable)) {
    partable <- lavpartable
  }
  if (is.null(GLIST)) {
    GLIST <- lavmodel@GLIST
  }
  if (is.null(est.std)) {
    est.std <- lav_standardize_lv(
      lavobject = lavobject,
      partable = partable, est = est, GLIST = GLIST,
      cov.std = cov.std, lv.var = lv.var, lavmodel = lavmodel,
      lavpartable = lavpartable
    )
  }

  out <- est.std
  N <- length(est.std)
  stopifnot(N == length(partable$lhs))

  VY <- lav_model_vy(
    lavmodel = lavmodel, GLIST = GLIST,
    diagonal.only = TRUE
  )


  for (g in 1:lavmodel@nblocks) {
    ov.names <- lav_partable_vnames(lavpartable, "ov", block = g) # not user
    lv.names <- lav_partable_vnames(lavpartable, "lv", block = g)

    if (is.null(ov.var)) {
      OV2 <- VY[[g]]
      # replace zero values by NA (but keep negative values)
      zero.idx <- which(abs(OV2) < .Machine$double.eps)
      if (length(zero.idx) > 0L) {
        OV2[zero.idx] <- as.numeric(NA)
      }

      # replace negative values by NA (for sqrt)
      tmp.OV2 <- OV2
      neg.idx <- which(tmp.OV2 < 0)
      if (length(neg.idx) > 0L) {
        tmp.OV2[neg.idx] <- as.numeric(NA)
      }
      OV <- sqrt(tmp.OV2)
    } else {
      OV2 <- ov.var[[g]]
      OV <- sqrt(OV2)
    }

    if (lavmodel@conditional.x) {
      # extend OV with ov.names.x
      ov.names.x <- lav_partable_vnames(lavpartable, "ov.x", block = g)
      ov.names.nox <- lav_partable_vnames(lavpartable, "ov.nox", block = g)
      ov.names <- c(ov.names.nox, ov.names.x)
      OV2 <- c(OV2, diag(cov.x[[g]]))
      OV <- c(OV, sqrt(diag(cov.x[[g]])))
    }

    # 1a. "=~" regular indicators
    idx <- which(partable$op == "=~" & !(partable$rhs %in% lv.names) &
      partable$block == g)
    out[idx] <- out[idx] / OV[match(partable$rhs[idx], ov.names)]

    # 1b. "=~" regular higher-order lv indicators

    # 1c. "=~" indicators that are both in ov and lv
    # idx <- which(partable$op == "=~" & partable$rhs %in% ov.names
    #                             & partable$rhs %in% lv.names &
    #             partable$block == g)

    # 2. "~" regressions (and "<~")
    idx <- which((partable$op == "~" | partable$op == "<~") &
      partable$lhs %in% ov.names &
      partable$block == g)
    out[idx] <- out[idx] / OV[match(partable$lhs[idx], ov.names)]

    idx <- which((partable$op == "~" | partable$op == "<~") &
      partable$rhs %in% ov.names &
      partable$block == g)
    out[idx] <- out[idx] * OV[match(partable$rhs[idx], ov.names)]

    # 3a. "~~" ov
    # ATTENTION: in Mplus 4.1, the off-diagonal residual covariances
    #            were computed by the formula cov(i,j) / sqrt(i.var*j.var)
    #            were i.var and j.var where diagonal elements of OV
    #
    #            in Mplus 6.1 (but also AMOS and EQS), the i.var and j.var
    #            elements are the 'THETA' diagonal elements!!

    # variances
    rv.idx <- which(partable$op == "~~" & !(partable$lhs %in% lv.names) &
      partable$lhs == partable$rhs &
      partable$block == g)
    # out[rv.idx] <- ( out[rv.idx] / OV[ match(partable$lhs[rv.idx], ov.names) ]
    #                             / OV[ match(partable$rhs[rv.idx], ov.names) ] )
    out[rv.idx] <- (out[rv.idx] /
      OV2[match(partable$lhs[rv.idx], ov.names)])

    # covariances ov
    # three types:
    # - only lhs is OV (and fixed.x = FALSE)
    # - only rhs is OV (and fixed.x = FALSE)
    # - both lhs and rhs are OV (regular case)
    if (cov.std) {
      if (!is.complex(est[rv.idx])) {
        RV <- sqrt(abs(est[rv.idx]))
      } else {
        RV <- sqrt(est[rv.idx])
      }
      rv.names <- partable$lhs[rv.idx]
    }

    # left
    idx.lhs <- which(partable$op == "~~" &
      !(partable$lhs %in% lv.names) &
      partable$lhs != partable$rhs &
      partable$block == g)
    if (length(idx.lhs) > 0L) {
      if (cov.std == FALSE) {
        out[idx.lhs] <-
          (out[idx.lhs] / OV[match(partable$lhs[idx.lhs], ov.names)])
      } else {
        out[idx.lhs] <-
          (out[idx.lhs] / RV[match(partable$lhs[idx.lhs], rv.names)])
      }
    }

    # right
    idx.rhs <- which(partable$op == "~~" &
      !(partable$rhs %in% lv.names) &
      partable$lhs != partable$rhs &
      partable$block == g)
    if (length(idx.rhs) > 0L) {
      if (cov.std == FALSE) {
        out[idx.rhs] <-
          (out[idx.rhs] / OV[match(partable$rhs[idx.rhs], ov.names)])
      } else {
        out[idx.rhs] <-
          (out[idx.rhs] / RV[match(partable$rhs[idx.rhs], rv.names)])
      }
    }

    # 3b. "~~" lv
    # idx <- which(partable$op == "~~" & partable$rhs %in% lv.names &
    #             partable$block == g)

    # 4a. "~1" ov
    idx <- which(partable$op == "~1" & !(partable$lhs %in% lv.names) &
      partable$block == g)
    out[idx] <- out[idx] / OV[match(partable$lhs[idx], ov.names)]

    # 4b. "~1" lv
    # idx <- which(partable$op == "~1" & partable$lhs %in% lv.names &
    #             partable$block == g)

    # 4c. "|" thresholds
    idx <- which(partable$op == "|" & !(partable$lhs %in% lv.names) &
      partable$block == g)
    out[idx] <- out[idx] / OV[match(partable$lhs[idx], ov.names)]

    # 4d. "~*~" scales
    idx <- which(partable$op == "~*~" & !(partable$lhs %in% lv.names) &
      partable$block == g)
    out[idx] <- 1.0
  }

  # 5a ":="
  idx <- which(partable$op == ":=")
  if (length(idx) > 0L) {
    x <- out[partable$free & !duplicated(partable$free)]
    out[idx] <- lavmodel@def.function(x)
  }

  # 5b "=="
  idx <- which(partable$op == "==")
  if (length(idx) > 0L) {
    x <- out[partable$free & !duplicated(partable$free)]
    out[idx] <- lavmodel@ceq.function(x)
  }

  # 5c. "<" or ">"
  idx <- which((partable$op == "<" | partable$op == ">"))
  if (length(idx) > 0L) {
    x <- out[partable$free & !duplicated(partable$free)]
    out[idx] <- lavmodel@cin.function(x)
  }

  out
}


lav_standardize_all_nox <- function(lavobject = NULL,
                                    partable = NULL, est = NULL, est.std = NULL,
                                    GLIST = NULL, cov.std = TRUE, ov.var = NULL,
                                    lv.var = NULL,
                                    lavmodel = NULL, lavpartable = NULL,
                                    cov.x = NULL) {
  if (is.null(lavobject)) {
    stopifnot(!is.null(lavmodel))
    stopifnot(!is.null(lavpartable))
    if (is.null(est)) {
      if (!is.null(lavpartable$est)) {
        est <- lavpartable$est # if this changes, tag @TDJorgensen in commit message
      } else {
        lav_msg_stop(gettext("could not find `est' in lavpartable"))
      }
    }
  } else {
    lavmodel <- lavobject@Model
    lavpartable <- lavobject@ParTable
    if (is.null(est)) {
      est <- lav_object_inspect_est(lavobject)
    }
    if (lavmodel@conditional.x) {
      if (is.null(cov.x)) {
        # try SampleStats slot
        # if("SampleStats" %in% slotNames(lavobject)) {
        #    cov.x <- lavobject@SampleStats@cov.x
        if (!is.null(lavobject@implied$cov.x[[1]])) {
          cov.x <- lavobject@implied$cov.x # if this changes, tag @TDJorgensen in commit message
        } else {
          # perhaps lavaanList object
          # extract it from GLIST per block
          cov.x <- vector("list", length = lavmodel@nblocks)
          for (b in seq_len(lavmodel@nblocks)) {
            # which mm belong to block b?
            mm.in.block <- (seq_len(lavmodel@nmat[b]) +
              cumsum(c(0, lavmodel@nmat))[b])
            MLIST <- lavmodel@GLIST[mm.in.block]
            cov.x[[b]] <- MLIST[["cov.x"]]
          }
        }
      }
    }
  }

  if (is.null(partable)) {
    partable <- lavpartable
  }
  if (is.null(GLIST)) {
    GLIST <- lavmodel@GLIST
  }
  if (is.null(est.std)) {
    est.std <- lav_standardize_lv(
      lavobject = lavobject,
      partable = partable, est = est, GLIST = GLIST,
      cov.std = cov.std, lv.var = lv.var, lavmodel = lavmodel,
      lavpartable = lavpartable
    )
  }


  out <- est.std
  N <- length(est.std)
  stopifnot(N == length(partable$lhs))

  VY <- lav_model_vy(
    lavmodel = lavmodel, GLIST = GLIST,
    diagonal.only = TRUE
  )


  for (g in 1:lavmodel@nblocks) {
    ov.names <- lav_partable_vnames(lavpartable, "ov", block = g)
    ov.names.x <- lav_partable_vnames(lavpartable, "ov.x", block = g)
    ov.names.nox <- lav_partable_vnames(lavpartable, "ov.nox", block = g)
    lv.names <- lav_partable_vnames(lavpartable, "lv", block = g)

    if (is.null(ov.var)) {
      OV2 <- VY[[g]]
      # replace zero values by NA (but keep negative values)
      zero.idx <- which(abs(OV2) < .Machine$double.eps)
      if (length(zero.idx) > 0L) {
        OV2[zero.idx] <- as.numeric(NA)
      }

      # replace negative values by NA (for sqrt)
      tmp.OV2 <- OV2
      neg.idx <- which(tmp.OV2 < 0)
      if (length(neg.idx) > 0L) {
        tmp.OV2[neg.idx] <- as.numeric(NA)
      }
      OV <- sqrt(tmp.OV2)
    } else {
      OV2 <- ov.var[[g]]
      OV <- sqrt(OV2)
    }


    if (lavmodel@conditional.x) {
      # extend OV with ov.names.x
      ov.names.x <- lav_partable_vnames(lavpartable, "ov.x", block = g)
      ov.names <- c(ov.names.nox, ov.names.x)
      OV2 <- c(OV2, diag(cov.x[[g]]))
      OV <- c(OV, sqrt(diag(cov.x[[g]])))
    }

    # 1a. "=~" regular indicators
    idx <- which(partable$op == "=~" & !(partable$rhs %in% lv.names) &
      partable$block == g)
    out[idx] <- out[idx] / OV[match(partable$rhs[idx], ov.names)]

    # 1b. "=~" regular higher-order lv indicators

    # 1c. "=~" indicators that are both in ov and lv
    # idx <- which(partable$op == "=~" & partable$rhs %in% ov.names
    #                             & partable$rhs %in% lv.names &
    #             partable$block == g)

    # 2. "~" regressions (and "<~")
    idx <- which((partable$op == "~" | partable$op == "<~") &
      partable$lhs %in% ov.names &
      partable$block == g)
    out[idx] <- out[idx] / OV[match(partable$lhs[idx], ov.names)]

    idx <- which((partable$op == "~" | partable$op == "<~") &
      partable$rhs %in% ov.names.nox &
      partable$block == g)
    out[idx] <- out[idx] * OV[match(partable$rhs[idx], ov.names.nox)]

    # 3a. "~~" ov
    # ATTENTION: in Mplus 4.1, the off-diagonal residual covariances
    #            were computed by the formula cov(i,j) / sqrt(i.var*j.var)
    #            were i.var and j.var where diagonal elements of OV
    #
    #            in Mplus 6.1 (but also AMOS and EQS), the i.var and j.var
    #            elements are the 'THETA' diagonal elements!!

    # variances
    rv.idx <- which(partable$op == "~~" & !(partable$lhs %in% lv.names) &
      !(partable$lhs %in% ov.names.x) &
      partable$lhs == partable$rhs &
      partable$block == g)
    # out[rv.idx] <- ( out[rv.idx] / OV[ match(partable$lhs[rv.idx], ov.names) ]
    #                            / OV[ match(partable$rhs[rv.idx], ov.names) ] )
    out[rv.idx] <- (out[rv.idx] /
      OV2[match(partable$lhs[rv.idx], ov.names)])

    # covariances ov
    # three types:
    # - only lhs is OV (and fixed.x = FALSE)
    # - only rhs is OV (and fixed.x = FALSE)
    # - both lhs and rhs are OV (regular case)
    if (cov.std) {
      if (!is.complex(est[rv.idx])) {
        RV <- sqrt(abs(est[rv.idx]))
      } else {
        RV <- sqrt(est[rv.idx])
      }
      rv.names <- partable$lhs[rv.idx]
    }

    # left
    idx.lhs <- which(partable$op == "~~" &
      !(partable$lhs %in% lv.names) &
      !(partable$lhs %in% ov.names.x) &
      partable$lhs != partable$rhs &
      partable$block == g)
    if (length(idx.lhs) > 0L) {
      if (cov.std == FALSE) {
        out[idx.lhs] <-
          (out[idx.lhs] / OV[match(partable$lhs[idx.lhs], ov.names)])
      } else {
        out[idx.lhs] <-
          (out[idx.lhs] / RV[match(partable$lhs[idx.lhs], rv.names)])
      }
    }

    # right
    idx.rhs <- which(partable$op == "~~" &
      !(partable$rhs %in% lv.names) &
      !(partable$rhs %in% ov.names.x) &
      partable$lhs != partable$rhs &
      partable$block == g)
    if (length(idx.rhs) > 0L) {
      if (cov.std == FALSE) {
        out[idx.rhs] <-
          (out[idx.rhs] / OV[match(partable$rhs[idx.rhs], ov.names)])
      } else {
        out[idx.rhs] <-
          (out[idx.rhs] / RV[match(partable$rhs[idx.rhs], rv.names)])
      }
    }

    # 3b. "~~" lv
    # idx <- which(partable$op == "~~" & partable$rhs %in% lv.names &
    #             partable$block == g)

    # 4a. "~1" ov
    idx <- which(partable$op == "~1" & !(partable$lhs %in% lv.names) &
      !(partable$lhs %in% ov.names.x) &
      partable$block == g)
    out[idx] <- out[idx] / OV[match(partable$lhs[idx], ov.names)]

    # 4b. "~1" lv
    # idx <- which(partable$op == "~1" & partable$lhs %in% lv.names &
    #             partable$block == g)

    # 4c. "|" thresholds
    idx <- which(partable$op == "|" & !(partable$lhs %in% lv.names) &
      partable$block == g)
    out[idx] <- out[idx] / OV[match(partable$lhs[idx], ov.names)]

    # 4d. "~*~" scales
    idx <- which(partable$op == "~*~" & !(partable$lhs %in% lv.names) &
      partable$block == g)
    out[idx] <- 1.0
  }

  # 5a ":="
  idx <- which(partable$op == ":=")
  if (length(idx) > 0L) {
    x <- out[partable$free & !duplicated(partable$free)]
    out[idx] <- lavmodel@def.function(x)
  }

  # 5b "=="
  idx <- which(partable$op == "==")
  if (length(idx) > 0L) {
    x <- out[partable$free & !duplicated(partable$free)]
    out[idx] <- lavmodel@ceq.function(x)
  }

  # 5c. "<" or ">"
  idx <- which((partable$op == "<" | partable$op == ">"))
  if (length(idx) > 0L) {
    x <- out[partable$free & !duplicated(partable$free)]
    out[idx] <- lavmodel@cin.function(x)
  }

  out
}

lav_unstandardize_ov <- function(partable, ov.var = NULL, cov.std = TRUE) {
  # check if ustart is missing; if so, look for est
  if (is.null(partable$ustart)) {
    partable$ustart <- partable$est
  }

  # check if block is missing
  if (is.null(partable$block)) {
    partable$block <- rep(1L, length(partable$ustart))
  }

  stopifnot(!any(is.na(partable$ustart)))
  est <- out <- partable$ustart
  N <- length(est)

  # nblocks
  nblocks <- lav_partable_nblocks(partable)

  # if ov.var is NOT a list, make a list
  if (!is.list(ov.var)) {
    tmp <- ov.var
    ov.var <- vector("list", length = nblocks)
    ov.var[1:nblocks] <- list(tmp)
  }

  for (g in 1:nblocks) {
    ov.names <- lav_partable_vnames(partable, "ov", block = g) # not user
    lv.names <- lav_partable_vnames(partable, "lv", block = g)

    OV <- sqrt(ov.var[[g]])

    # 1a. "=~" regular indicators
    idx <- which(partable$op == "=~" & !(partable$rhs %in% lv.names) &
      partable$block == g)
    out[idx] <- out[idx] * OV[match(partable$rhs[idx], ov.names)]

    # 1b. "=~" regular higher-order lv indicators

    # 1c. "=~" indicators that are both in ov and lv
    # idx <- which(partable$op == "=~" & partable$rhs %in% ov.names
    #                             & partable$rhs %in% lv.names &
    #             partable$block == g)

    # 2. "~" regressions (and "<~")
    idx <- which((partable$op == "~" | partable$op == "<~") &
      partable$lhs %in% ov.names &
      partable$block == g)
    out[idx] <- out[idx] * OV[match(partable$lhs[idx], ov.names)]

    idx <- which((partable$op == "~" | partable$op == "<~") &
      partable$rhs %in% ov.names &
      partable$block == g)
    out[idx] <- out[idx] / OV[match(partable$rhs[idx], ov.names)]

    # 3a. "~~" ov
    # ATTENTION: in Mplus 4.1, the off-diagonal residual covariances
    #            were computed by the formula cov(i,j) / sqrt(i.var*j.var)
    #            were i.var and j.var where diagonal elements of OV
    #
    #            in Mplus 6.1 (but also AMOS and EQS), the i.var and j.var
    #            elements are the 'THETA' diagonal elements!!

    # variances
    rv.idx <- which(partable$op == "~~" & !(partable$lhs %in% lv.names) &
      partable$lhs == partable$rhs &
      partable$block == g)
    out[rv.idx] <- (out[rv.idx] * OV[match(partable$lhs[rv.idx], ov.names)]
      * OV[match(partable$rhs[rv.idx], ov.names)])

    # covariances
    idx <- which(partable$op == "~~" & !(partable$lhs %in% lv.names) &
      partable$lhs != partable$rhs &
      partable$block == g)
    if (length(idx) > 0L) {
      if (cov.std == FALSE) {
        out[idx] <- (out[idx] * OV[match(partable$lhs[idx], ov.names)]
          * OV[match(partable$rhs[idx], ov.names)])
      } else {
        if (!is.complex(out[rv.idx])) {
          RV <- sqrt(abs(out[rv.idx]))
        } else {
          RV <- sqrt(out[rv.idx])
        }
        rv.names <- partable$lhs[rv.idx]
        out[idx] <- (out[idx] * RV[match(partable$lhs[idx], rv.names)]
          * RV[match(partable$rhs[idx], rv.names)])
      }
    }

    # 3b. "~~" lv
    # idx <- which(partable$op == "~~" & partable$rhs %in% lv.names &
    #             partable$block == g)

    # 4a. "~1" ov
    idx <- which(partable$op == "~1" & !(partable$lhs %in% lv.names) &
      partable$block == g)
    out[idx] <- out[idx] * OV[match(partable$lhs[idx], ov.names)]

    # 4b. "~1" lv
    # idx <- which(partable$op == "~1" & partable$lhs %in% lv.names &
    #             partable$block == g)
  }

  # 5a ":="
  # 5b "=="
  # 5c. "<" or ">"

  out
}

# extract info from model
lav_model_plotinfo <- function(model = NULL, infile = NULL, varlv = FALSE) {
  if (is.null(model) == is.null(infile)) {
    lav_msg_stop(gettext("either model or infile must be specified"))
  }
  edge_label <- function(label, fix) {
    if (label == "" && fix == "") {
      return("")
    }
    if (label == "") {
      return(fix)
    }
    if (fix == "") {
      return(label)
    }
    paste(label, fix, sep = "=")
  }
  if (!is.null(infile)) {
    if (!file.exists(infile)) {
      lav_msg_stop(gettextf("Infile %s not found!", infile))
    }
    model <- readLines(infile)
  }
  if (inherits(model, "lavaan")) {
    model <- as.data.frame(model@ParTable)
    model <- model[model$user == 1, ]
    model$fixed <- round(model$est, 3L)
    if (max(model$block) == 1L) model$block <- rep(0L, length(model$block))
    model$est <- NULL
  }
  if (is.list(model) && !is.null(model$op) && !is.null(model$lhs) &&
    !is.null(model$rhs) && !is.null(model$label) &&
    !is.null(model$fixed)) {
    tbl <- as.data.frame(model)
  } else if (is.character(model)) {
    tbl <- lavParseModelString(
      model.syntax = model,
      as.data.frame. = TRUE
    )
  } else {
    lav_msg_stop(gettext(
      "model, or content of infile, not in interpretable form!"
    ))
  }
  if (is.null(tbl$block)) {
    tbl$block <- 0L
  } else if (all(tbl$block == tbl$block[1L])) {
    tbl$block <- 0L
  } else {
    blockmin <- min(tbl$block)
    tbl$block[tbl$block == blockmin] <- 999L
    tbl$block[tbl$block != 999L] <- 2L
    tbl$block[tbl$block == 999L] <- 1L
  }
  create_node_id <- function(blok, naam) {
    if (blok == 0L) {
      naam
    } else {
      paste(blok, naam, sep = ".")
    }
  }
  maxedges <- nrow(tbl)
  maxnodes <- 2 * maxedges
  nodes <- data.frame(
    id = character(maxnodes),
    naam = character(maxnodes),
    tiepe = character(maxnodes), # ov, lv, varlv, cv, wov, bov, const
    # cv: composite; wov = within; bov = between; const = intercept
    blok = integer(maxnodes)
  )
  edges <- data.frame(
    id = integer(maxedges),
    label = character(maxedges),
    van = character(maxedges),
    naar = character(maxedges),
    tiepe = character(maxedges) # lavaan operator, behalve ~~ self -> "~~~"
  )
  curnode <- 0L
  curedge <- 0L
  for (i in seq.int(nrow(tbl))) {
    if (tbl$op[i] == "=~") {
      #### =~ : is manifested by ####
      # lhs node
      jl <- match(create_node_id(tbl$block[i], tbl$lhs[i]),
                  nodes$id, nomatch = 0L)
      if (jl == 0L) {
        curnode <- curnode + 1L
        jl <- curnode
        nodes$naam[curnode] <- tbl$lhs[i]
        nodes$tiepe[curnode] <- "lv"
        nodes$blok[curnode] <- tbl$block[i]
        nodes$id[curnode] <- create_node_id(nodes$blok[curnode],
                                            nodes$naam[curnode])
      } else {
        nodes$tiepe[jl] <- "lv"
      }
      # rhs node
      jr <- match(create_node_id(tbl$block[i], tbl$rhs[i]),
                  nodes$id, nomatch = 0L)
      nodetype <- "ov"
      if (length(unique(tbl$block[tbl$rhs == tbl$rhs[i]])) > 1L) {
        nodetype <- switch(tbl$block[i],
          "wov",
          "bov"
        )
      }
      if (jr == 0L) {
        curnode <- curnode + 1L
        jr <- curnode
        nodes$naam[curnode] <- tbl$rhs[i]
        nodes$tiepe[curnode] <- nodetype
        nodes$blok[curnode] <- tbl$block[i]
        nodes$id[curnode] <- create_node_id(nodes$blok[curnode],
                                            nodes$naam[curnode])
      } else {
        if (nodes$tiepe[jr] == "") nodes$tiepe[jr] <- nodetype
      }
      # edge
      curedge <- curedge + 1L
      edges$id[curedge] <- curedge
      edges$label[curedge] <- edge_label(tbl$label[i], tbl$fixed[i])
      edges$van[curedge] <- nodes$id[jl]
      edges$naar[curedge] <- nodes$id[jr]
      edges$tiepe[curedge] <- tbl$op[i]
    } else if (tbl$op[i] == "<~") {
      #### <~ : is a result of ####
      # lhs node
      jl <- match(create_node_id(tbl$block[i], tbl$lhs[i]),
                  nodes$id, nomatch = 0L)
      if (jl == 0L) {
        curnode <- curnode + 1L
        jl <- curnode
        nodes$naam[curnode] <- tbl$lhs[i]
        nodes$tiepe[curnode] <- "cv"
        nodes$blok[curnode] <- tbl$block[i]
        nodes$id[curnode] <- create_node_id(nodes$blok[curnode],
                                            nodes$naam[curnode])
      } else {
        nodes$tiepe[jl] <- "cv"
      }
      # rhs node
      jr <- match(create_node_id(tbl$block[i], tbl$rhs[i]),
                  nodes$id, nomatch = 0L)
      nodetype <- "ov"
      if (length(unique(tbl$block[tbl$rhs == tbl$rhs[i]])) > 1L) {
        nodetype <- switch(tbl$block[i],
          "wov",
          "bov"
        )
      }
      if (jr == 0L) {
        curnode <- curnode + 1L
        jr <- curnode
        nodes$naam[curnode] <- tbl$rhs[i]
        nodes$tiepe[curnode] <- nodetype
        nodes$blok[curnode] <- tbl$block[i]
        nodes$id[curnode] <- create_node_id(nodes$blok[curnode],
                                            nodes$naam[curnode])
      } else {
        if (nodes$tiepe[jr] == "") nodes$tiepe[jr] <- nodetype
      }
      # edge
      curedge <- curedge + 1L
      edges$id[curedge] <- curedge
      edges$label[curedge] <- edge_label(tbl$label[i], tbl$fixed[i])
      edges$van[curedge] <- nodes$id[jr]
      edges$naar[curedge] <- nodes$id[jl]
      edges$tiepe[curedge] <- tbl$op[i]
    } else if (tbl$op[i] == "~") {
      #### ~ : is regressed on ####
      # lhs node
      jl <- match(create_node_id(tbl$block[i], tbl$lhs[i]),
                                 nodes$id, nomatch = 0L)
      nodetype <- "ov"
      if (length(unique(tbl$block[tbl$rhs == tbl$rhs[i]])) > 1L) {
        nodetype <- switch(tbl$block[i],
          "wov",
          "bov"
        )
      }
      if (jl == 0L) {
        curnode <- curnode + 1L
        jl <- curnode
        nodes$naam[curnode] <- tbl$lhs[i]
        nodes$tiepe[curnode] <- nodetype
        nodes$blok[curnode] <- tbl$block[i]
        nodes$id[curnode] <- create_node_id(nodes$blok[curnode],
                                            nodes$naam[curnode])
      } else {
        if (nodes$tiepe[jl] == "") nodes$tiepe[jl] <- nodetype
      }
      # rhs node
      jr <- match(create_node_id(tbl$block[i], tbl$rhs[i]),
                  nodes$id, nomatch = 0L)
      if (jr == 0L) {
        curnode <- curnode + 1L
        jr <- curnode
        nodes$naam[curnode] <- tbl$rhs[i]
        nodes$tiepe[curnode] <- nodetype
        nodes$blok[curnode] <- tbl$block[i]
        nodes$id[curnode] <- create_node_id(nodes$blok[curnode],
                                            nodes$naam[curnode])
      } else {
        if (nodes$tiepe[jr] == "") nodes$tiepe[jr] <- nodetype
      }
      # edge
      curedge <- curedge + 1L
      edges$id[curedge] <- curedge
      edges$label[curedge] <- edge_label(tbl$label[i], tbl$fixed[i])
      edges$van[curedge] <- nodes$id[jr]
      edges$naar[curedge] <- nodes$id[jl]
      edges$tiepe[curedge] <- tbl$op[i]
    } else if (tbl$op[i] == "~1") {
      #### ~1 : intercept ####
      # lhs node
      jl <- match(create_node_id(tbl$block[i], tbl$lhs[i]),
                  nodes$id, nomatch = 0L)
      nodetype <- "ov"
      if (length(unique(tbl$block[tbl$rhs == tbl$lhs[i] |
        tbl$lhs == tbl$lhs[i]])) > 1L) {
        nodetype <- switch(tbl$block[i],
          "wov",
          "bov"
        )
      }
      if (jl == 0L) {
        curnode <- curnode + 1L
        jl <- curnode
        nodes$naam[curnode] <- tbl$lhs[i]
        nodes$tiepe[curnode] <- nodetype
        nodes$blok[curnode] <- tbl$block[i]
        nodes$id[curnode] <- create_node_id(nodes$blok[curnode],
                                            nodes$naam[curnode])
      } else {
        if (nodes$tiepe[jl] == "") nodes$tiepe[jl] <- nodetype
      }
      # rhs node
      jr <- 0L
      curnode <- curnode + 1L
      jr <- curnode
      nodes$naam[curnode] <- paste0("1van", tbl$lhs[i])
      nodes$tiepe[curnode] <- "const"
      nodes$blok[curnode] <- tbl$block[i]
      nodes$id[curnode] <- create_node_id(nodes$blok[curnode],
                                          nodes$naam[curnode])
      # edge
      curedge <- curedge + 1L
      edges$id[curedge] <- curedge
      edges$label[curedge] <- edge_label(tbl$label[i], tbl$fixed[i])
      edges$van[curedge] <- nodes$id[jr]
      edges$naar[curedge] <- nodes$id[jl]
      edges$tiepe[curedge] <- "~"
    } else if (tbl$op[i] == "~~") {
      #### ~~ : is correlated with ####
      # lhs node
      jl <- match(create_node_id(tbl$block[i], tbl$lhs[i]),
                  nodes$id, nomatch = 0L)
      nodetype <- "ov"
      if (length(unique(tbl$block[tbl$rhs == tbl$lhs[i] |
        tbl$lhs == tbl$lhs[i]])) > 1L) {
        nodetype <- switch(tbl$block[i],
          "wov",
          "bov"
        )
      }
      if (jl == 0L) {
        curnode <- curnode + 1L
        jl <- curnode
        nodes$naam[curnode] <- tbl$lhs[i]
        nodes$tiepe[curnode] <- nodetype
        nodes$blok[curnode] <- tbl$block[i]
        nodes$id[curnode] <- create_node_id(nodes$blok[curnode],
                                            nodes$naam[curnode])
      } else {
        if (nodes$tiepe[jl] == "") nodes$tiepe[jl] <- nodetype
      }
      # rhs node
      jr <- match(create_node_id(tbl$block[i], tbl$rhs[i]),
                  nodes$id, nomatch = 0L)
      nodetype <- "ov"
      if (length(unique(tbl$block[tbl$rhs == tbl$lhs[i] |
        tbl$lhs == tbl$lhs[i]])) > 1L) {
        nodetype <- switch(tbl$block[i],
          "wov",
          "bov"
        )
      }
      if (jr == 0L) {
        curnode <- curnode + 1L
        jr <- curnode
        nodes$naam[curnode] <- tbl$rhs[i]
        nodes$tiepe[curnode] <- nodetype
        nodes$blok[curnode] <- tbl$block[i]
        nodes$id[curnode] <- create_node_id(nodes$blok[curnode],
                                            nodes$naam[curnode])
      } else {
        if (nodes$tiepe[jr] == "") nodes$tiepe[jr] <- nodetype
      }
      # edge
      curedge <- curedge + 1L
      edges$id[curedge] <- curedge
      edges$label[curedge] <- edge_label(tbl$label[i], tbl$fixed[i])
      if (varlv && jl == jr) { # prepare for handling varlv
        edges$label[curedge] <- paste(tbl$label[i], tbl$fixed[i], sep = "=")
      }
      edges$van[curedge] <- nodes$id[jr]
      edges$naar[curedge] <- nodes$id[jl]
      edges$tiepe[curedge] <- ifelse(jl == jr, "~~~", tbl$op[i])
    }
  }
  # aanpassingen voor varlv
  if (varlv && any(edges$tiepe == "~~~")) {
    #       wijzigen varianties
    welke <- which(edges$tiepe == "~~~")
    varlvnodes <- rep(0L, length(welke))
    lvnodes <- rep(0L, length(welke))
    for (ji in seq_along(welke)) {
      j <- welke[ji]
      curnode <- curnode + 1L
      nodes$naam[curnode] <- gsub("=.*$", "", edges$label[j])
      if (nodes$naam[curnode] == "")
        nodes$naam[curnode] <- paste0("var", edges$van[j])
      nodes$tiepe[curnode] <- "varlv"
      nodes$blok[curnode] <- nodes$blok[which(nodes$id == edges$van[j])[[1L]]]
      nodes$id[curnode] <- create_node_id(nodes$blok[curnode],
                                          nodes$naam[curnode])
      varlvnodes[ji] <- curnode
      lvnodes[ji] <- edges$van[j]
      edges$van[j] <- nodes$id[curnode]
      edges$tiepe[j] <- "~."
      edges$label[j] <- ifelse(grepl("=", edges$label[j]),
        gsub("^.*=", "", edges$label[j]), ""
      )
    }
    #       wijzigen covarianties
    for (j1 in seq_along(welke)) {
      for (j2 in seq_along(welke)) {
        if (j1 != j2 && any(edges$tiepe == "~~" &
          edges$van == lvnodes[j1] & edges$naar == lvnodes[j2])) {
          edg <- which(edges$tiepe == "~~" &
            edges$van == lvnodes[j1] & edges$naar == lvnodes[j2])[[1L]]
          edges$van[edg] <- varlvnodes[j1]
          edges$naar[edg] <- varlvnodes[j2]
        }
      }
    }
  }
  nodes <- nodes[seq.int(curnode), ]
  edges <- edges[seq.int(curedge), ]
  edges$label <- trimws(edges$label)
  if (any(grepl("[<>&]", c(edges$label, nodes$naam)))) {
    lav_msg_warn(gettext(
      "some labels contain '<', '>' or '&', which can result in errors!"
    ))
  }
  list(nodes = nodes, edges = edges)
}

lav_pml_plrt2 <- function(lavobject = NULL, lavmodel = NULL, lavdata = NULL,
                          lavsamplestats = NULL, lavpartable = NULL,
                          lavoptions = NULL, x = NULL, VCOV = NULL,
                          lavcache = NULL) {
  lavpta <- NULL
  if (!is.null(lavobject)) {
    lavmodel <- lavobject@Model
    lavdata <- lavobject@Data
    lavoptions <- lavobject@Options
    lavsamplestats <- lavobject@SampleStats
    lavcache <- lavobject@Cache
    lavpartable <- lav_partable_set_cache(lavobject@ParTable, lavobject@pta)
    lavpta <- lavobject@pta
  }
  if (is.null(lavpta)) {
    lavpta <- lav_partable_attributes(lavpartable)
    lavpartable <- lav_partable_set_cache(lavpartable, lavpta)
  }

  if (is.null(x)) {
    # compute 'fx' = objective function value
    # (NOTE: since 0.5-18, NOT divided by N!!)
    fx <- lav_model_objective(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats,
      lavdata = lavdata,
      lavcache = lavcache
    )
    H0.fx <- as.numeric(fx)
    H0.fx.group <- attr(fx, "fx.group")
  } else {
    H0.fx <- attr(attr(x, "fx"), "fx.pml")
    H0.fx.group <- attr(attr(x, "fx"), "fx.group")
  }

  # fit a saturated model 'fittedSat'
  ModelSat <- lav_partable_unrestricted(
    lavobject = NULL,
    lavdata = lavdata,
    lavoptions = lavoptions,
    lavpta = lavpta,
    lavsamplestats = lavsamplestats
  )

  # FIXME: se="none", test="none"??
  Options <- lavoptions
  Options$se <- "none"
  Options$test <- "none"
  Options$baseline <- FALSE
  Options$h1 <- FALSE
  fittedSat <- lavaan(ModelSat,
    slotOptions = Options, verbose = FALSE,
    slotSampleStats = lavsamplestats,
    slotData = lavdata, slotCache = lavcache
  )
  fx <- lav_model_objective(
    lavmodel = fittedSat@Model,
    lavsamplestats = fittedSat@SampleStats,
    lavdata = fittedSat@Data,
    lavcache = fittedSat@Cache
  )
  SAT.fx <- as.numeric(fx)
  SAT.fx.group <- attr(fx, "fx.group")

  # we also need a `saturated model', but where the moments are based
  # on the model-implied sample statistics under H0
  ModelSat2 <-
    lav_partable_unrestricted(
      lavobject = NULL,
      lavdata = lavdata,
      lavoptions = lavoptions,
      lavpta = lavpta,
      lavsamplestats = NULL,
      sample.cov = lav_model_sigma(lavmodel),
      sample.mean = lav_model_mu(lavmodel),
      sample.th = lav_model_th(lavmodel),
      sample.th.idx = lavsamplestats@th.idx
    )

  Options2 <- Options
  Options2$optim.method <- "none"
  Options2$optim.force.converged <- TRUE
  fittedSat2 <- lavaan(ModelSat2,
    slotOptions = Options2, verbose = FALSE,
    slotSampleStats = lavsamplestats,
    slotData = lavdata, slotCache = lavcache
  )

  # the code below was contributed by Myrsini Katsikatsou (Jan 2015)

  # for now, only a single group is supported:
  # g = 1L


  ########################### The code for PLRT for overall goodness of fit

  ##### Section 1. Compute the asymptotic mean and variance
  #####            of the first quadratic quantity
  # if(is.null(VCOV)) {
  #    VCOV <- lav_model_vcov(lavmodel       = lavmodel,
  #                           lavsamplestats = lavsamplestats,
  #                           lavoptions     = lavoptions,
  #                           lavdata        = lavdata,
  #                           lavpartable    = lavpartable,
  #                           lavcache       = lavcache)
  # }
  # G.inv
  # InvG_attheta0 <- lavsamplestats@ntotal * VCOV[,]
  # Hessian
  # H_attheta0 <- solve(attr(VCOV, "E.inv"))

  # inverted observed information ('H.inv')
  if (is.null(VCOV)) {
    H0.inv <- lav_model_information_observed(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavoptions = lavoptions,
      lavcache = lavcache, augmented = TRUE, inverted = TRUE
    )
  } else {
    H0.inv <- attr(VCOV, "E.inv")
  }

  # first order information ('J')
  if (is.null(VCOV)) {
    J0 <- lav_model_information_firstorder(
      lavmodel = lavmodel, lavoptions = lavoptions,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavcache = lavcache
    )[, ]
  } else {
    # we do not get J, but J.group, FIXME?
    J0 <- lav_model_information_firstorder(
      lavmodel = lavmodel, lavoptions = lavoptions,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavcache = lavcache
    )[, ]
  }

  # inverted Godambe information
  G0.inv <- H0.inv %*% J0 %*% H0.inv

  H0tmp_prod1 <- H0.inv %*% J0
  # H0tmp_prod1 <- InvG_attheta0 %*% H_attheta0
  H0tmp_prod2 <- H0tmp_prod1 %*% H0tmp_prod1
  E_tww <- sum(diag(H0tmp_prod1))
  var_tww <- 2 * sum(diag(H0tmp_prod2))

  ##### Section 2: Compute the asymptotic mean and variance
  #####            of the second quadratic quantity.
  tmp.options <- fittedSat2@Options
  tmp.options$se <- "robust.huber.white"
  VCOV.Sat2 <- lav_model_vcov(
    lavmodel = fittedSat2@Model,
    lavsamplestats = fittedSat2@SampleStats,
    lavoptions = tmp.options,
    lavdata = fittedSat2@Data,
    lavpartable = fittedSat2@ParTable,
    lavcache = fittedSat2@Cache
  )
  # G.inv at vartheta_0
  InvG_at_vartheta0 <- lavsamplestats@ntotal * VCOV.Sat2[, ]
  # Hessian at vartheta_0
  H_at_vartheta0 <- solve(attr(VCOV.Sat2, "E.inv")) # should always work
  # H1.inv <- lavTech(fittedSat2, "inverted.information.observed")
  # J1     <- lavTech(fittedSat2, "information.first.order")
  # H1tmp_prod1 <- H1.inv %*% J1
  H1tmp_prod1 <- InvG_at_vartheta0 %*% H_at_vartheta0
  H1tmp_prod2 <- H1tmp_prod1 %*% H1tmp_prod1
  E_tzz <- sum(diag(H1tmp_prod1))
  var_tzz <- 2 * sum(diag(H1tmp_prod2))


  ##### Section 3: Compute the asymptotic covariance
  #####            of the two quadratic quantities

  drhodpsi_MAT <- vector("list", length = lavsamplestats@ngroups)
  group.values <- lav_partable_group_values(fittedSat2@ParTable)
  for (g in 1:lavsamplestats@ngroups) {
    delta.g <- lav_model_delta(lavmodel)[[g]]
    # order of the rows: first the thresholds, then the correlations
    # we need to map the rows of delta.g to the rows/cols of H_at_vartheta0
    # of H1

    PT <- fittedSat2@ParTable
    PT$label <- lav_partable_labels(PT)
    free.idx <- which(PT$free > 0 & PT$group == group.values[g])
    PARLABEL <- PT$label[free.idx]

    # for now, we can assume that lav_model_delta will always return
    # the thresholds first, then the correlations
    #
    # later, we should add a (working) add.labels = TRUE option to
    # lav_model_delta
    th.names <- lavpta$vnames$th[[g]]
    ov.names <- lavpta$vnames$ov[[g]]
    tmp <- utils::combn(ov.names, 2)
    cor.names <- paste(tmp[1, ], "~~", tmp[2, ], sep = "")
    NAMES <- c(th.names, cor.names)
    if (g > 1L) {
      NAMES <- paste(NAMES, ".g", g, sep = "")
    }

    par.idx <- match(PARLABEL, NAMES)
    drhodpsi_MAT[[g]] <- delta.g[par.idx, , drop = FALSE]
  }
  drhodpsi_mat <- do.call(rbind, drhodpsi_MAT)

  # tmp_prod <- ( t(drhodpsi_mat) %*% H_at_vartheta0 %*%
  #                 drhodpsi_mat %*% InvG_attheta0 %*%
  #                 H_attheta0 %*% InvG_attheta0 )
  tmp_prod <- (t(drhodpsi_mat) %*% H_at_vartheta0 %*%
    drhodpsi_mat %*% H0.inv %*% J0 %*% G0.inv)
  cov_tzztww <- 2 * sum(diag(tmp_prod))

  ##### Section 4: compute the adjusted PLRT and its p-value
  PLRTH0Sat <- 2 * (H0.fx - SAT.fx)
  PLRTH0Sat.group <- 2 * (H0.fx.group - SAT.fx.group)
  asym_mean_PLRTH0Sat <- E_tzz - E_tww
  asym_var_PLRTH0Sat <- var_tzz + var_tww - 2 * cov_tzztww
  scaling.factor <- (asym_mean_PLRTH0Sat / (asym_var_PLRTH0Sat / 2))
  FSA_PLRT_SEM <- (asym_mean_PLRTH0Sat / (asym_var_PLRTH0Sat / 2)) * PLRTH0Sat
  adjusted_df <- (asym_mean_PLRTH0Sat * asym_mean_PLRTH0Sat) /
    (asym_var_PLRTH0Sat / 2)
  # In some very few cases (simulations show very few cases
  #                         in small sample sizes)
  # the adjusted_df is a negative number, we should then
  # print a warning like: "The adjusted df is computed to be a negative number
  # and for this the first and second moment adjusted PLRT is not computed." .
  pvalue <- 1 - pchisq(FSA_PLRT_SEM, df = adjusted_df)

  list(
    PLRTH0Sat = PLRTH0Sat, PLRTH0Sat.group = PLRTH0Sat.group,
    stat = FSA_PLRT_SEM, df = adjusted_df, p.value = pvalue,
    scaling.factor = scaling.factor
  )
}
############################################################################

# new version of lav_data_simulate (replaced lav_data_simulate_old)
# from lavaan 0.6-1
# YR 23 March 2018
#
# - calls lavaan directly to get model-implied statistics
# - allows for groups with different sets of variables
# -


lav_data_simulate <- function(model = NULL,
                            cmd.pop = "sem",
                            ...,
                            # data properties
                            sample.nobs = 1000L,
                            cluster.idx = NULL,
                            # control
                            empirical = FALSE,
                            # output
                            add.labels = TRUE,
                            return.fit = FALSE,
                            output = "data.frame") {
  # dotdotdot
  dotdotdot <- list(...)
  dotdotdot.orig <- dotdotdot

  # remove/override some options
  dotdotdot$verbose <- FALSE
  dotdotdot$debug <- FALSE
  dotdotdot$data <- NULL
  dotdotdot$sample.cov <- NULL


  # add sample.nobs/group.label to lavaan call
  dotdotdot$sample.nobs <- sample.nobs

  # always use meanstructure = TRUE
  dotdotdot$meanstructure <- TRUE


  # remove 'ordered' argument: we will first pretend we generate
  # continuous data only
  dotdotdot$ordered <- NULL

  # 'fit' population model
  fit.pop <- do.call(cmd.pop, args = c(list(model = model), dotdotdot))

  # categorical?
  if (fit.pop@Model@categorical) {
    # refit, as if continuous only
    dotdotdot$ordered <- NULL
    fit.con <- do.call(cmd.pop, args = c(list(model = model), dotdotdot))
    # restore
    dotdotdot$ordered <- dotdotdot.orig$ordered
  } else {
    fit.con <- fit.pop
  }

  # extract model implied statistics and data slot
  lavimplied <- fit.con@implied # take continuous mean/cov
  lavdata <- fit.pop@Data
  lavmodel <- fit.pop@Model
  lavpartable <- fit.pop@ParTable
  lavoptions <- fit.pop@Options

  # number of groups/levels
  ngroups <- lav_partable_ngroups(lavpartable)
  nblocks <- lav_partable_nblocks(lavpartable)

  # check sample.nobs argument
  if (lavdata@nlevels > 1L) {
    # multilevel
    if (is.null(cluster.idx)) {
      # default? -> 1000 per block
      if (is.null(sample.nobs)) {
        sample.nobs <- rep.int(
          c(
            1000L,
            rep.int(100L, lavdata@nlevels - 1L)
          ),
          times = ngroups
        )
      } else {
        # we assume sample.nobs only contains a single number
        sample.nobs <- rep.int(
          c(
            sample.nobs,
            rep.int(100L, lavdata@nlevels - 1L)
          ),
          times = ngroups
        )
      }
    } else {
      # we got a cluster.idx argument
      if (!is.list(cluster.idx)) {
        cluster.idx <- rep(list(cluster.idx), ngroups)
      }

      if (!is.null(sample.nobs) && (length(sample.nobs) > 1L ||
        sample.nobs != 1000L)) {
        lav_msg_warn(gettext(
          "sample.nobs will be ignored if cluster.idx is provided"))
      }
      sample.nobs <- numeric(nblocks)
      for (g in seq_len(ngroups)) {
        gg <- (g - 1) * lavdata@nlevels + 1L
        sample.nobs[gg] <- length(cluster.idx[[g]])
        sample.nobs[gg + 1] <- length(unique(cluster.idx[[g]]))
      }
    }
  } else {
    # single level
    if (length(sample.nobs) == ngroups) {
      # nothing to do
    } else if (ngroups > 1L && length(sample.nobs) == 1L) {
      sample.nobs <- rep.int(sample.nobs, ngroups)
    } else {
      lav_msg_stop(gettextf(
        "ngroups = %1$s but sample.nobs has length = %2$s",
        ngroups, length(sample.nobs)))
    }
  }

  # check if ov.names are the same for each group
  if (ngroups > 1L) {
    N1 <- lavdata@ov.names[[1]]
    if (!all(sapply(
      lavdata@ov.names,
      function(x) all(x %in% N1)
    ))) {
      if (output == "data.frame") {
        output <- "matrix"
        lav_msg_warn(gettext(
          "groups do not contain the same set of variables;
          changing output= argument to \"matrix\""))
      }
    }
  }

  # prepare data containers
  X <- vector("list", length = nblocks)

  # generate data per BLOCK
  for (b in seq_len(nblocks)) {
    if (lavoptions$conditional.x) {
      lav_msg_stop(gettext("conditional.x is not ready yet"))
    } else {
      COV <- lavimplied$cov[[b]]
      MU <- lavimplied$mean[[b]]
    }

    # if empirical = TRUE, rescale by N/(N-1), so that estimator=ML
    # returns exact results
    if (empirical) {
      # check if sample.nobs is large enough
      if (sample.nobs[b] < NCOL(COV)) {
        lav_msg_stop(gettextf(
          "empirical = TRUE requires sample.nobs = %1$s to be larger than the
          number of variables = %2$s in block = %3$s",
          sample.nobs[b], NCOL(COV), b
        ))
      }
      if (lavdata@nlevels > 1L && (b %% lavdata@nlevels == 1L)) {
        COV <- COV * sample.nobs[b] / (sample.nobs[b] - sample.nobs[b + 1])
      } else {
        COV <- COV * sample.nobs[b] / (sample.nobs[b] - 1)
      }
    }

    # generate normal data (using sign-invariant method for reproducibility)
    tmp <- try(
      lav_mvrnorm(
        n = sample.nobs[b],
        mu = MU, Sigma = COV, empirical = empirical, byrow = TRUE
      ),
      silent = TRUE
    )

    if (inherits(tmp, "try-error")) {
      # something went wrong; most likely: non-positive COV?
      ev <- eigen(COV, symmetric = TRUE, only.values = TRUE)$values
      if (any(ev < 0)) {
        lav_msg_stop(gettextf(
          "model-implied covariance matrix is not positive-definite in block
          = %1$s; smallest eigen value = %2$s; change the model parameters.",
          b, round(min(ev), 5)))
      } else {
        lav_msg_stop(gettextf("data generation failed for block = %s", b))
      }
    } else {
      X[[b]] <- unname(tmp)
    }
  } # block

  if (output == "block") {
    return(X)
  }

  # if multilevel, make a copy, and create X[[g]] per group
  if (lavdata@nlevels > 1L) {
    X.block <- X
    X <- vector("list", length = ngroups)
  }

  # assemble data per group
  group.values <- lav_partable_group_values(lavpartable)
  for (g in 1:ngroups) {
    # multilevel?
    if (lavdata@nlevels > 1L) {
      # which block?
      bb <- (g - 1) * lavdata@nlevels + 1L

      Lp <- lavdata@Lp[[g]]
      p.tilde <- length(lavdata@ov.names[[g]])
      tmp1 <- matrix(0, nrow(X.block[[bb]]), p.tilde + 1L) # one extra for
      tmp2 <- matrix(0, nrow(X.block[[bb]]), p.tilde + 1L) # the clus id

      # level 1
      # if(empirical) {
      if (FALSE) {
        # force the within-cluster means to be zero (for both.idx vars)
        Y2 <- unname(as.matrix(aggregate(X.block[[bb]],
          # NOTE: cluster.idx becomes a factor
          # should be 111122223333...
          by = list(cluster.idx[[g]]), FUN = mean, na.rm = TRUE
        )[, -1]))
        # don't touch within-only variables
        w.idx <- match(Lp$within.idx[[2]], Lp$ov.idx[[1]])
        Y2[, w.idx] <- 0

        # center cluster-wise
        Y1c <- X.block[[bb]] - Y2[cluster.idx[[g]], , drop = FALSE]

        # this destroys the within covariance matrix
        sigma.sqrt <- lav_matrix_symmetric_sqrt(lavimplied$cov[[bb]])
        NY <- NROW(Y1c)
        S <- cov(Y1c) * (NY - 1) / NY
        S.inv <- solve(S)
        S.inv.sqrt <- lav_matrix_symmetric_sqrt(S.inv)

        # transform
        X.block[[bb]] <- Y1c %*% S.inv.sqrt %*% sigma.sqrt
      }
      tmp1[, Lp$ov.idx[[1]]] <- X.block[[bb]]

      # level 2
      tmp2[, Lp$ov.idx[[2]]] <- X.block[[bb + 1L]][cluster.idx[[g]], ,
        drop = FALSE
      ]
      # final
      X[[g]] <- tmp1 + tmp2

      # cluster id
      X[[g]][, p.tilde + 1L] <- cluster.idx[[g]]
    }

    # add variable names?
    if (add.labels) {
      if (lavdata@nlevels > 1L) {
        colnames(X[[g]]) <- c(lavdata@ov.names[[g]], "cluster")
      } else {
        colnames(X[[g]]) <- lavdata@ov.names[[g]]
      }
    }

    # any categorical variables?
    ov.ord <- lav_object_vnames(fit.pop, "ov.ord", group = group.values[g])
    if (is.list(ov.ord)) {
      # multilvel -> use within level only
      ov.ord <- ov.ord[[1L]]
    }
    if (length(ov.ord) > 0L) {
      ov.names <- lavdata@ov.names[[g]]

      # which block?
      bb <- (g - 1) * lavdata@nlevels + 1L

      # th/names
      TH.VAL <- as.numeric(fit.pop@implied$th[[bb]])
      if (length(lavmodel@num.idx[[bb]]) > 0L) {
        NUM.idx <- which(lavmodel@th.idx[[bb]] == 0)
        TH.VAL <- TH.VAL[-NUM.idx]
      }
      th.names <- fit.pop@pta$vnames$th[[bb]]
      TH.NAMES <- sapply(strsplit(th.names,
        split = "|",
        fixed = TRUE
      ), "[[", 1L)

      # use thresholds to cut
      for (o in ov.ord) {
        o.idx <- which(o == ov.names)
        th.idx <- which(o == TH.NAMES)
        th.val <- c(-Inf, sort(TH.VAL[th.idx]), +Inf)
        # center (because model-implied 'mean' may be nonzero)
        tmp <- X[[g]][, o.idx]
        tmp <- tmp - mean(tmp, na.rm = TRUE)
        X[[g]][, o.idx] <- cut(tmp, th.val, labels = FALSE)
      }
    }
  }


  # output
  if (output == "matrix") {
    if (ngroups == 1L) {
      out <- X[[1L]]
    } else {
      out <- X
    }
  } else if (output == "data.frame") {
    if (ngroups == 1L) {
      # convert to data.frame
      out <- as.data.frame(X[[1L]], stringsAsFactors = FALSE)
    } else if (ngroups > 1L) {
      # rbind
      out <- do.call("rbind", X)

      # add group column
      group <- rep.int(1:ngroups, times = sapply(X, NROW))
      out <- cbind(out, group)

      # convert to data.frame
      out <- as.data.frame(out, stringsAsFactors = FALSE)
    }
  } else if (output == "cov") {
    if (ngroups == 1L) {
      out <- cov(X[[1L]])
    } else {
      out <- lapply(X, cov)
    }
  } else {
    lav_msg_stop(gettextf("unknown option for argument output: %s", output))
  }

  if (return.fit) {
    attr(out, "fit") <- fit.pop
  }

  out
}

# # # # # # # # # # # # # # #
# # lavaan main function  # #
# # # # # # # # # # # # # # #
#
# main user-visible cfa/sem/growth functions
#
# initial version: YR 25/03/2009
# added lavoptions YR 02/08/2010
# major revision: YR 9/12/2010: - new workflow (since 0.4-5)
#                               - merge cfa/sem/growth functions
# YR 25/02/2012: changed data slot (from list() to S4); data@X contains data

# YR 26 Jan 2017: use '...' to capture the never-ending list of options
# YR 07 Feb 2023: add ov.order= argument
# HJ 18 Oct 2023: extend PML to allow sampling weights
# LDW 26 Feb 2024: split lavaan in smaller steps
#
lavaan <- function(
    # user specified model: can be syntax, parameter Table, ...
    model = NULL,
    # data (second argument, most used)
    data = NULL,
    # variable information
    ordered = NULL,
    # sampling weights
    sampling.weights = NULL,
    # summary data
    sample.cov = NULL,
    sample.mean = NULL,
    sample.th = NULL,
    sample.nobs = NULL,
    # multiple groups?
    group = NULL,
    # multiple levels?
    cluster = NULL,
    # constraints
    constraints = "",
    # user-specified variance matrices
    WLS.V = NULL, # nolint
    NACOV = NULL, # nolint
    # internal order of ov.names
    ov.order = "model",
    # full slots from previous fits
    slotOptions = NULL, # nolint
    slotParTable = NULL, # nolint
    slotSampleStats = NULL, # nolint
    slotData = NULL, # nolint
    slotModel = NULL, # nolint
    slotCache = NULL, # nolint
    sloth1 = NULL,
    # options (dotdotdot)
    ...) {
  # start timer
  start.time0 <- proc.time()[3]
  timing <- list()
  timing$start.time <- start.time0

  # ------------- adapt parameters -----------------
  mc <- match.call(expand.dots = TRUE)
  temp <- lav_lavaan_step00_parameters(
    matchcall = mc,
    syscall   = sys.call(), # to get main arguments without partial matching
    dotdotdot = list(...)
  )
  lavmc <- temp$mc
  dotdotdot <- temp$dotdotdot
  cluster <- lavmc$cluster
  rm(mc)

  # store current random seed (if any)
  if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
    temp.seed <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
  } else {
    temp.seed <- NULL
  }

  # ------------- handling of warn/debug/verbose switches ----------
  if (!is.null(dotdotdot$debug)) {
    current.debug <- lav_debug()
    if (lav_debug(dotdotdot$debug))
      on.exit(lav_debug(current.debug), TRUE)
    dotdotdot$debug <- NULL
    if (lav_debug()) {
      dotdotdot$warn <- TRUE       # force warnings if debug
      dotdotdot$verbose <- TRUE    # force verbose if debug
    }
  }
  if (!is.null(dotdotdot$warn)) {
    current.warn <- lav_warn()
    if (lav_warn(dotdotdot$warn))
      on.exit(lav_warn(current.warn), TRUE)
    dotdotdot$warn <- NULL
  }
  if (!is.null(dotdotdot$verbose)) {
    current.verbose <- lav_verbose()
    if (lav_verbose(dotdotdot$verbose))
      on.exit(lav_verbose(current.verbose), TRUE)
    dotdotdot$verbose <- NULL
  }

  # ------------ check data ------------------------
  temp <- lav_lavaan_step00_checkdata(
    data        = data,
    dotdotdot   = dotdotdot,
    sample.cov  = sample.cov,
    sample.nobs = sample.nobs,
    sample.mean = sample.mean,
    sample.th   = sample.th,
    NACOV       = NACOV,
    WLS.V       = WLS.V,
    ov.order    = ov.order
  )
  data <- temp$data
  dotdotdot <- temp$dotdotdot
  sample.cov <- temp$sample.cov
  sample.nobs <- temp$sample.nobs
  sample.mean <- temp$sample.mean
  sample.th <- temp$sample.th
  NACOV <- temp$NACOV # nolint
  WLS.V <- temp$WLS.V # nolint
  ov.order <- temp$ov.order

  timing <- ldw_add_timing(timing, "init")

  # ------------ ov.names 1 -----  initial flat model --------------------
  # if parser not specified, take default one
  if (is.null(dotdotdot$parser)) {
    opt.default <- lav_options_default()
    useparser <- opt.default$parser
  } else {
    useparser <- dotdotdot$parser
  }

  flat.model <- lav_lavaan_step01_ovnames_initflat(
    slotParTable     = slotParTable,
    model            = model,
    dotdotdot.parser = useparser
  )

  # ------------ ov.names 1b ----- handle 'old way' for composites -------
  if (!is.null(dotdotdot$composites) && !dotdotdot$composites &&
     any(flat.model$op == "<~")) {
    flat.model <- lav_lavaan_step01_ovnames_composites(flat.model)
  }

  # ------------ ov.names 2 ------ handle ov.order -----------------------
  flat.model <- lav_lavaan_step01_ovnames_ovorder(
    flat.model = flat.model,
    ov.order   = ov.order,
    data       = data,
    sample.cov = sample.cov,
    slotData   = slotData
  )

  # ------------ ov.names 3 ------- group blocks ------------------
  ngroups <- 1L # default value
  temp <- lav_lavaan_step01_ovnames_group(
    flat.model = flat.model,
    ngroups    = ngroups
  )
  flat.model <- temp$flat.model
  ov.names <- temp$ov.names
  ov.names.x <- temp$ov.names.x
  ov.names.y <- temp$ov.names.y
  lv.names <- temp$lv.names
  group.values <- temp$group.values
  ngroups <- temp$ngroups

  # ------------ ov.names 4 ------ sanity checks ------------------
  lav_lavaan_step01_ovnames_checklv(
    lv.names    = lv.names,
    ov.names    = ov.names,
    data        = data,
    sample.cov  = sample.cov,
    dotdotdot   = dotdotdot,
    slotOptions = slotOptions
  )

  # ------------ ov.names 5 ------ handle ov.names.l --------------
  temp <- lav_lavaan_step01_ovnames_namesl(
    data         = data,
    cluster      = cluster,
    flat.model   = flat.model,
    group.values = group.values,
    ngroups      = ngroups
  )
  flat.model <- temp$flat.model
  ov.names.l <- temp$ov.names.l

  # ------------ ov.names 6 ------ sanity check ordered --------------
  ordered <- lav_lavaan_step01_ovnames_ordered(
    ordered    = ordered,
    flat.model = flat.model,
    data       = data
  )
  timing <- ldw_add_timing(timing, "ov.names")

  # ------------ lavoptions --------------------
  lavoptions <- lav_lavaan_step02_options(
    slotOptions      = slotOptions,
    slotData         = slotData,
    flat.model       = flat.model,
    ordered          = ordered,
    sample.cov       = sample.cov,
    sample.mean      = sample.mean,
    sample.th        = sample.th,
    sample.nobs      = sample.nobs,
    ov.names.l       = ov.names.l,
    sampling.weights = sampling.weights,
    constraints      = constraints,
    group            = group,
    ov.names.x       = ov.names.x,
    ov.names.y       = ov.names.y,
    dotdotdot        = dotdotdot,
    cluster          = cluster,
    data             = data
  )
  # fixed.x = FALSE? set ov.names.x = character(0L)
  # new in 0.6-1
  if (!lavoptions$fixed.x) {
    ov.names.x <- character(0L)
  }

  timing <- ldw_add_timing(timing, "Options")

  # ------------ lavdata ------------------------
  temp <- lav_lavaan_step03_data(
    slotData         = slotData,
    lavoptions       = lavoptions,
    ov.names         = ov.names,
    ov.names.y       = ov.names.y,
    group            = group,
    data             = data,
    cluster          = cluster,
    ov.names.x       = ov.names.x,
    ov.names.l       = ov.names.l,
    ordered          = ordered,
    sampling.weights = sampling.weights,
    sample.cov       = sample.cov,
    sample.mean      = sample.mean,
    sample.th        = sample.th,
    sample.nobs      = sample.nobs,
    slotParTable     = slotParTable,
    ngroups          = ngroups,
    dotdotdot        = dotdotdot,
    flat.model       = flat.model,
    model            = model, # in case model is a lavaan object
    NACOV            = NACOV,
    WLS.V            = WLS.V
  )
  lavdata <- temp$lavdata
  lavoptions <- temp$lavoptions

  timing <- ldw_add_timing(timing, "Data")

  # ------------ lavpartable -------------------
  temp <- lav_lavaan_step04_partable(
    slotParTable = slotParTable,
    model        = model,
    flat.model   = flat.model,
    lavoptions   = lavoptions,
    lavdata      = lavdata,
    constraints  = constraints
  )
  lavoptions <- temp$lavoptions
  lavpartable <- temp$lavpartable
  timing <- ldw_add_timing(timing, "ParTable")

  # ------------ lavpta ------------------------
  # lavpta <- lav_lavaan_step04_pta(
  #   lavpartable = lavpartable,
  #   lavoptions  = lavoptions
  # )
  # timing <- ldw_add_timing(timing, "lavpta")

  # ------------ lavsamplestats ---------------
  lavsamplestats <- lav_lavaan_step05_samplestats(
    slotSampleStats = slotSampleStats,
    lavdata         = lavdata,
    lavoptions      = lavoptions,
    WLS.V           = WLS.V,
    NACOV           = NACOV,
    sample.cov      = sample.cov,
    sample.mean     = sample.mean,
    sample.th       = sample.th,
    sample.nobs     = sample.nobs,
    ov.names        = ov.names,
    ov.names.x      = ov.names.x,
    lavpartable     = lavpartable
  )
  timing <- ldw_add_timing(timing, "SampleStats")

  # ------------ lavh1 ------------------------
  lavh1 <- lav_lavaan_step06_h1(
    sloth1         = sloth1,
    lavoptions     = lavoptions,
    lavsamplestats = lavsamplestats,
    lavdata        = lavdata,
    lavpartable    = lavpartable
  )
  timing <- ldw_add_timing(timing, "h1")

  # ------------ bounds ------------------------
  lavpartable <- lav_lavaan_step07_bounds(
    lavoptions     = lavoptions,
    lavh1          = lavh1,
    lavdata        = lavdata,
    lavsamplestats = lavsamplestats,
    lavpartable    = lavpartable
  )
  timing <- ldw_add_timing(timing, "bounds")

  # ------------ lavstart ----------------------
  lavpartable <- lav_lavaan_step08_start(
    slotModel      = slotModel,
    lavoptions     = lavoptions,
    lavpartable    = lavpartable,
    lavsamplestats = lavsamplestats,
    lavh1          = lavh1
  )

  timing <- ldw_add_timing(timing, "start")

  # ------------ model -------------------------
  temp <- lav_lavaan_step09_model(
    slotModel      = slotModel,
    lavoptions     = lavoptions,
    lavpartable    = lavpartable,
    lavsamplestats = lavsamplestats,
    lavdata        = lavdata
  )
  lavpartable <- temp$lavpartable
  lavmodel <- temp$lavmodel

  timing <- ldw_add_timing(timing, "Model")

  # -------- lavcache ----------------------------------
  lavcache <- lav_lavaan_step10_cache(
    slotCache        = slotCache,
    lavdata          = lavdata,
    lavmodel         = lavmodel,
    lavpartable      = lavpartable,
    lavoptions       = lavoptions,
    sampling.weights = sampling.weights
  )
  timing <- ldw_add_timing(timing, "cache")

  # -------- est + lavoptim ----------------------------
  temp <- lav_lavaan_step11_estoptim(
    lavdata        = lavdata,
    lavmodel       = lavmodel,
    lavcache       = lavcache,
    lavsamplestats = lavsamplestats,
    lavh1          = lavh1,
    lavoptions     = lavoptions,
    lavpartable    = lavpartable
  )
  lavoptim <- temp$lavoptim
  lavmodel <- temp$lavmodel
  lavpartable <- temp$lavpartable
  x <- temp$x
  # store eqs if present in x
  laveqs <- list()
  if (!is.null(attr(x, "eqs"))) {
    laveqs <- attr(x, "eqs")
  }

  timing <- ldw_add_timing(timing, "optim")

  # -------- lavimplied + lavloglik --------------------
  lavimplied <- lav_lavaan_step12_implied(
    lavoptions = lavoptions,
    lavmodel   = lavmodel
  )
  timing <- ldw_add_timing(timing, "implied")

  lavloglik <- lav_lavaan_step12_loglik(
    lavoptions     = lavoptions,
    lavdata        = lavdata,
    lavsamplestats = lavsamplestats,
    lavh1          = lavh1,
    lavimplied     = lavimplied,
    lavmodel       = lavmodel
  )
  timing <- ldw_add_timing(timing, "loglik")

  # ----------- lavvcov + lavboot -------------------
  temp <- lav_lavaan_step13_vcov_boot(
    lavoptions     = lavoptions,
    lavmodel       = lavmodel,
    lavsamplestats = lavsamplestats,
    lavdata        = lavdata,
    lavpartable    = lavpartable,
    lavcache       = lavcache,
    lavimplied     = lavimplied,
    lavh1          = lavh1,
    x              = x
  )
  lavpartable <- temp$lavpartable
  lavvcov <- temp$lavvcov
  VCOV <- temp$VCOV # nolint
  lavmodel <- temp$lavmodel
  lavboot <- temp$lavboot

  timing <- ldw_add_timing(timing, "vcov")

  # ----------- lavtest ----------
  lavtest <- lav_lavaan_step14_test(
    lavoptions     = lavoptions,
    lavmodel       = lavmodel,
    lavsamplestats = lavsamplestats,
    lavdata        = lavdata,
    lavpartable    = lavpartable,
    lavcache       = lavcache,
    lavimplied     = lavimplied,
    lavh1          = lavh1,
    x              = x,
    VCOV           = VCOV,
    lavloglik      = lavloglik
  )
  timing <- ldw_add_timing(timing, "test")

  # ----------- lavfit ----------
  lavfit <- lav_lavaan_step14_fit(
    lavpartable = lavpartable,
    lavmodel    = lavmodel,
    lavimplied  = lavimplied,
    x           = x,
    VCOV        = VCOV,
    lavtest     = lavtest
  )
  timing <- ldw_add_timing(timing, "Fit")

  # ----------- baseline ----------------------------
  lavbaseline <- lav_lavaan_step15_baseline(
    lavoptions = lavoptions,
    lavsamplestats = lavsamplestats,
    lavdata = lavdata,
    lavcache = lavcache,
    lavh1 = lavh1,
    lavpartable = lavpartable
  )
  timing <- ldw_add_timing(timing, "baseline")

  # ----------- rotation ---------------------------
  temp <- lav_lavaan_step16_rotation(
    lavoptions     = lavoptions,
    lavmodel       = lavmodel,
    lavpartable    = lavpartable,
    lavh1          = lavh1,
    lavdata        = lavdata,
    x              = x,
    lavvcov        = lavvcov,
    VCOV           = VCOV,
    lavcache       = lavcache,
    lavimplied     = lavimplied,
    lavsamplestats = lavsamplestats
  )
  lavpartable <- temp$lavpartable
  lavmodel <- temp$lavmodel
  lavvcov <- temp$lavvcov

  timing <- ldw_add_timing(timing, "rotation")

  # ------ lavaan result  ----------------
  out <- lav_lavaan_step17_lavaan(
    lavmc          = lavmc,
    timing         = timing,
    lavoptions     = lavoptions,
    lavpartable    = lavpartable,
    lavdata        = lavdata,
    lavsamplestats = lavsamplestats,
    lavmodel       = lavmodel,
    lavcache       = lavcache,
    lavfit         = lavfit,
    lavboot        = lavboot,
    lavoptim       = lavoptim,
    lavimplied     = lavimplied,
    lavloglik      = lavloglik,
    lavvcov        = lavvcov,
    lavtest        = lavtest,
    lavh1          = lavh1,
    lavbaseline    = lavbaseline,
    laveqs         = laveqs,
    start.time0    = start.time0
  )

  # restore random seed
  if (!is.null(temp.seed)) {
    assign(".Random.seed", temp.seed, envir = .GlobalEnv)
  } else if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
    # initially there was no .Random.seed, but we created one along the way
    # clean up
    remove(".Random.seed", envir = .GlobalEnv)
  }

  out
}
# # # # # #
# # cfa # #
# # # # # #
cfa <- function(
  model = NULL,
  data = NULL,
  ordered = NULL,
  sampling.weights = NULL,
  sample.cov = NULL,
  sample.mean = NULL,
  sample.th = NULL,
  sample.nobs = NULL,
  group = NULL,
  cluster = NULL,
  constraints = "",
  WLS.V = NULL, # nolint
  NACOV = NULL, # nolint
  ov.order = "model",
  ...) {
  sc <- sys.call()
  sc[["model.type"]] <- quote("cfa")
  # call mother function
  sc[[1L]] <- quote(lavaan::lavaan)
  eval(sc, parent.frame())
}
# # # # # #
# # sem # #
# # # # # #
sem <- function(
    model = NULL,
    data = NULL,
    ordered = NULL,
    sampling.weights = NULL,
    sample.cov = NULL,
    sample.mean = NULL,
    sample.th = NULL,
    sample.nobs = NULL,
    group = NULL,
    cluster = NULL,
    constraints = "",
    WLS.V = NULL, # nolint
    NACOV = NULL, # nolint
    ov.order = "model",
    ...) {
  sc <- sys.call()
  sc[["model.type"]] <- quote("sem")
  # call mother function
  sc[[1L]] <- quote(lavaan::lavaan)
  eval(sc, parent.frame())
}
# # # # # # # #
# # growth  # #
# # # # # # # #
growth <- function(
    model = NULL,
    data = NULL,
    ordered = NULL,
    sampling.weights = NULL,
    sample.cov = NULL,
    sample.mean = NULL,
    sample.th = NULL,
    sample.nobs = NULL,
    group = NULL,
    cluster = NULL,
    constraints = "",
    WLS.V = NULL, # nolint
    NACOV = NULL, # nolint
    ov.order = "model",
    ...) {
  sc <- sys.call()
  sc[["model.type"]] <- quote("growth")
  # call mother function
  sc[[1L]] <- quote(lavaan::lavaan)
  eval(sc, parent.frame())
}

# # # # # # # # # # # # # # # # # # #
# # help function ldw_add_timing  # #
# # # # # # # # # # # # # # # # # # #
ldw_add_timing <- function(timing, part) {
  # timing is a list with element start.time
  # this function adds an element with name as specified in parameter part
  # and the duration of the interval from start.time upto now
  # thereafter the element start.time is set to now (prepare for next call)
  # the adapted list is returned
  timenow <- proc.time()[3]
  timing[[part]] <- (timenow - timing$start.time)
  timing$start.time <- timenow

  timing
}

# create `full' parameter table, containing (almost) all parameters
# that could be free
#
# main motivation: univariate scores tests (modification indices)
#
lav_partable_full <- function(partable = NULL,
                              strict.exo = FALSE,
                              free = FALSE, start = FALSE) {
  # check minimum requirements: lhs, op, rhs
  stopifnot(
    !is.null(partable$lhs),
    !is.null(partable$op),
    !is.null(partable$rhs)
  )

  # lavpta?
  lavpta <- lav_partable_attributes(partable)

  # meanstructure
  if (!is.null(lavpta$meanstructure)) {
    meanstructure <- lavpta$meanstructure
  } else {
    # old object
    meanstructure <- any(partable$op == "~1")
  }

  # number of blocks
  nblocks <- lavpta$nblocks
  ngroups <- lavpta$ngroups
  nlevels <- lavpta$nlevels

  lhs <- rhs <- op <- character(0L)
  block <- group <- level <- integer(0L)

  # new in 0.6-3:
  GROUP.values <- lav_partable_group_values(partable)
  LEVEL.values <- lav_partable_level_values(partable)
  if (is.character(GROUP.values[1])) {
    group <- character(0L)
  }
  if (is.character(LEVEL.values[1L])) {
    level <- character(0L)
  }

  # block number
  b <- 0L
  for (g in 1:ngroups) {
    for (l in 1:nlevels) {
      # block
      b <- b + 1L

      ov.names <- lavpta$vnames$ov[[b]]
      ov.names.nox <- lavpta$vnames$ov.nox[[b]]
      ov.names.x <- lavpta$vnames$ov.x[[b]]
      ov.names.ind <- lavpta$vnames$ov.ind[[b]]
      ov.names.ord <- lavpta$vnames$ov.ord[[b]]

      lv.names <- lavpta$vnames$lv[[b]]

      # eqs.y, eqs.x
      eqs.names <- unique(c(
        lavpta$vnames$eqs.y[[b]],
        lavpta$vnames$eqs.x[[b]]
      ))
      if (length(eqs.names) > 0L) {
        eqs.y <- eqs.names
        if (strict.exo) {
          x.idx <- which(eqs.names %in% ov.names.x)
          if (length(x.idx) > 0L) {
            eqs.y <- eqs.names[-x.idx]
          }
        }
        eqs.x <- eqs.names
      } else {
        eqs.y <- character(0L)
        eqs.x <- character(0L)
      }

      # 1 "=~"
      l.lhs <- rep(lv.names, each = length(ov.names.nox))
      l.rhs <- rep(ov.names.nox, times = length(lv.names))

      # remove factor ~ eqs.y combinations, if any
      # because they also appear as a regression
      bad.idx <- which(l.lhs %in% lv.names &
        l.rhs %in% eqs.y)
      if (length(bad.idx) > 0L) {
        l.lhs <- l.lhs[-bad.idx]
        l.rhs <- l.rhs[-bad.idx]
      }
      l.op <- rep("=~", length(l.lhs))

      # 2a. "~~" ov ## FIXME: ov.names.nox or ov.names??
      # if(strict.exo) {
      OV <- ov.names.nox
      # } else {
      #    OV <- ov.names
      # }
      nx <- length(OV)
      idx <- lower.tri(matrix(0, nx, nx), diag = TRUE)
      ov.lhs <- rep(OV, each = nx)[idx] # fill upper.tri
      ov.rhs <- rep(OV, times = nx)[idx]
      ov.op <- rep("~~", length(ov.lhs))

      # remove dummy indicators that correlate with 'proper'
      # indicators; new in 0.6-14; fixed in 0.6-16
      ov.other <- ov.names[!ov.names %in% c(
        ov.names.ind, ov.names.x,
        eqs.x, eqs.y
      )]
      if (length(ov.other) > 0L) {
        bad.idx <- which((ov.lhs %in% ov.names &
          ov.rhs %in% ov.other) |
          (ov.lhs %in% ov.other &
            ov.rhs %in% ov.names))
        if (length(bad.idx) > 0L) {
          ov.lhs <- ov.lhs[-bad.idx]
          ov.rhs <- ov.rhs[-bad.idx]
          ov.op <- ov.op[-bad.idx]
        }
      }

      # exo ~~
      if (!strict.exo && length(ov.names.x) > 0L) {
        OV <- ov.names.x
        nx <- length(OV)
        idx <- lower.tri(matrix(0, nx, nx), diag = TRUE)
        more.lhs <- rep(OV, each = nx)[idx] # fill upper.tri
        more.rhs <- rep(OV, times = nx)[idx]
        ov.lhs <- c(ov.lhs, more.lhs)
        ov.rhs <- c(ov.rhs, more.rhs)
        ov.op <- c(ov.op, rep("~~", length(more.lhs)))
      }

      # 2b. "~~" lv
      nx <- length(lv.names)
      idx <- lower.tri(matrix(0, nx, nx), diag = TRUE)
      lv.lhs <- rep(lv.names, each = nx)[idx] # fill upper.tri
      lv.rhs <- rep(lv.names, times = nx)[idx]
      lv.op <- rep("~~", length(lv.lhs))

      # 3 regressions?
      r.lhs <- r.rhs <- r.op <- character(0)
      if (length(eqs.names) > 0L) {
        r.lhs <- rep(eqs.y, each = length(eqs.x))
        r.rhs <- rep(eqs.x, times = length(eqs.y))

        # remove self-arrows
        idx <- which(r.lhs == r.rhs)
        if (length(idx) > 0L) {
          r.lhs <- r.lhs[-idx]
          r.rhs <- r.rhs[-idx]
        }

        # remove indicator ~ factor if they exist
        bad.idx <- which(r.lhs %in% ov.names.ind &
          r.rhs %in% lv.names)
        if (length(bad.idx) > 0L) {
          r.lhs <- r.lhs[-bad.idx]
          r.rhs <- r.rhs[-bad.idx]
        }

        r.op <- rep("~", length(r.rhs))
      }

      # 4. intercepts
      int.lhs <- int.rhs <- int.op <- character(0)
      if (meanstructure) {
        if (strict.exo) {
          int.lhs <- c(ov.names.nox, lv.names)
        } else {
          int.lhs <- c(ov.names, lv.names)
        }
        int.rhs <- rep("", length(int.lhs))
        int.op <- rep("~1", length(int.lhs))
      }

      # 5. thresholds
      th.lhs <- th.rhs <- th.op <- character(0)
      if (length(ov.names.ord) > 0L) {
        th.names <- lavpta$vnames$th[[b]]
        tmp <- strsplit(th.names, "\\|")
        th.lhs <- sapply(tmp, function(x) x[1])
        th.rhs <- sapply(tmp, function(x) x[2])
        th.op <- rep("|", length(th.lhs))
      }

      # 6. scaling parameters
      delta.lhs <- delta.rhs <- delta.op <- character(0)
      if (ngroups > 1L && length(ov.names.ord) > 0L) {
        delta.lhs <- ov.names.ord
        delta.rhs <- ov.names.ord
        delta.op <- rep("~*~", length(delta.lhs))
      }

      # combine
      this.lhs <- c(
        l.lhs, ov.lhs, lv.lhs, r.lhs, int.lhs, th.lhs,
        delta.lhs
      )
      this.rhs <- c(
        l.rhs, ov.rhs, lv.rhs, r.rhs, int.rhs, th.rhs,
        delta.rhs
      )
      this.op <- c(
        l.op, ov.op, lv.op, r.op, int.op, th.op,
        delta.op
      )
      n.el <- length(this.lhs)

      lhs <- c(lhs, this.lhs)
      rhs <- c(rhs, this.rhs)
      op <- c(op, this.op)
      block <- c(block, rep(b, n.el))
      group <- c(group, rep(GROUP.values[g], n.el))
      level <- c(level, rep(LEVEL.values[l], n.el))
    } # level
  } # group

  LIST <- data.frame(
    lhs = lhs, op = op, rhs = rhs, block = block,
    group = group, level = level, stringsAsFactors = FALSE
  )

  if (free) {
    LIST$free <- rep(0L, nrow(LIST))
  }

  if (start) {
    LIST$start <- rep(0, nrow(LIST))
  }

  LIST
}

# export `lavaan' lav model description to third-party software
#

lav_export <- function(object, target = "lavaan", prefix = "sem",
                      dir.name = "lav_export", export = TRUE) {
  stopifnot(inherits(object, "lavaan"))
  # check object
  object <- lav_object_check_version(object)
  target <- tolower(target)

  # check for conditional.x = TRUE
  # if(object@Model@conditional.x) {
  #    stop("lavaan ERROR: this function is not (yet) available if conditional.x = TRUE")
  # }

  ngroups <- object@Data@ngroups
  if (ngroups > 1L) {
    group.label2 <- paste(".", object@Data@group.label, sep = "")
  } else {
    group.label2 <- ""
  }
  data.file <- paste(prefix, group.label2, ".", target, ".raw", sep = "")

  # 2. create syntax file
  if (target == "lavaan") {
    header <- ""
    syntax <- lav_export_lavaan(object)
    footer <- ""
    out <- paste(header, syntax, footer, sep = "")
  } else if (target == "mplus") {
    header <- lav_mplus_header(
      data.file = data.file,
      group.label = object@Data@group.label,
      ov.names = c(
        lav_partable_vnames(object@ParTable, "ov"),
        object@Data@sampling.weights
      ),
      ov.ord.names = lav_partable_vnames(object@ParTable, "ov.ord"),
      weight.name = object@Data@sampling.weights,
      listwise = lavInspect(object, "options")$missing == "listwise",
      estimator = lav_mplus_estimator(object),
      information = lavInspect(object, "options")$information,
      meanstructure = lavInspect(object, "meanstructure"),
      data.type = object@Data@data.type,
      nobs = object@Data@nobs[[1L]]
    )
    syntax <- lav_export_mplus(object, group.label = object@Data@group.label)
    footer <- paste("OUTPUT:\n  sampstat standardized tech1;\n")
    out <- paste(header, syntax, footer, sep = "")
  } else if (target == "lisrel") {
    syntax <- lav_export_lisrel(object)
  } else if (target == "eqs") {
    syntax <- lav_export_eqs(object)
  } else if (target == "sem") {
    syntax <- lav_export_sem(object)
  } else if (target == "openmx") {
    syntax <- lav_export_openmx(object)
  } else {
    lav_msg_stop(gettextf("target %s has not been implemented yet", target))
  }

  # export to file?
  if (export) {
    dir.create(path = dir.name)
    input.file <- paste(dir.name, "/", prefix, ".", target, ".in", sep = "")
    cat(out, file = input.file, sep = "")

    # write data (if available)
    if (identical(object@Data@data.type, "full")) {
      for (g in 1:ngroups) {
        if (is.null(object@Data@eXo[[g]])) {
          DATA <- object@Data@X[[g]]
        } else {
          DATA <- cbind(object@Data@X[[g]], object@Data@eXo[[g]])
        }
        if (!is.null(object@Data@weights[[g]])) {
          DATA <- cbind(DATA, object@Data@weights[[g]])
        }
        write.table(DATA,
          file = paste(dir.name, "/", data.file[g], sep = ""),
          na = "-999999",
          col.names = FALSE, row.names = FALSE, quote = FALSE
        )
      }
    } else if (identical(object@Data@data.type, "moment")) {
      for (g in 1:ngroups) {
        DATA <- object@SampleStats@cov[[g]]
        write.table(DATA,
          file = paste(dir.name, "/", data.file[g], sep = ""),
          na = "-999999",
          col.names = FALSE, row.names = FALSE, quote = FALSE
        )
      }
    } else {
      lav_msg_warn(gettext("not data available"))
    }
    return(invisible(out))
  } else {
    # just return the syntax file for inspection
    class(out) <- c("lavaan.character", "character")
  }

  out
}
lavExport <- lav_export     # synonym #nolint


lav_export_check <- function(lav) {
  if (inherits(lav, "lavaan")) {
    lav <- lav@ParTable
  } else if (is.list(lav)) {
    # nothing to do
  } else {
    lav_msg_stop(gettext("lav must be of class `lavaan' or a parTable"))
  }

  # check syntax
  if (is.null(lav$ustart)) lav$ustart <- lav$est

  # check if free is missing
  if (is.null(lav$free)) lav$free <- rep(0L, length(lav$ustart))

  # check if label is missing
  if (is.null(lav$label)) lav$label <- rep("", length(lav$ustart))

  # check if group is missing
  if (is.null(lav$group)) lav$group <- rep(1L, length(lav$ustart))

  # if eq.id not all zero, create labels instead
  # if(!is.null(lav$eq.id) && !all(lav$eq.id == 0L)) {
  #    lav$label <- paste("p",as.character(lav$eq.id), sep="")
  #    lav$label[lav$label == "p0"] <- ""
  # }

  lav
}

## FIXME: this is completely UNFINISHED (just  used to quickly get something)
lav_export_lavaan <- function(lav) {
  lav <- lav_export_check(lav)
  header <- "# this model syntax is autogenerated by lav_export\n"
  footer <- "\n"

  # intercepts
  int.idx <- which(lav$op == "~1")
  lav$op[int.idx] <- "~"
  lav$rhs[int.idx] <- "1"

  # spacing around operator
  lav$op <- paste(" ", lav$op, " ", sep = "")

  lav2 <- ifelse(lav$free != 0L,
    ifelse(lav$label == "",
      paste(lav$lhs, lav$op, lav$rhs, sep = ""),
      paste(lav$lhs, lav$op, lav$label, "*", lav$rhs,
        sep = ""
      )
    ),
    ifelse(lav$label == "",
      paste(lav$lhs, lav$op, lav$ustart, "*", lav$rhs,
        sep = ""
      ),
      paste(lav$lhs, lav$op, lav$ustart, "*", lav$rhs,
        "+", lav$label, "*", lav$rhs,
        sep = ""
      )
    )
  )

  body <- paste(lav2, collapse = "\n")
  out <- paste(header, body, footer, sep = "")
  class(out) <- c("lavaan.character", "character")
  out
}

lav_export_lisrel <- function(lav) {
  lav <- lav_export_check(lav)
  lav_msg_stop(gettext("this function needs revision"))
}

lav_export_eqs <- function(lav) {
  lav <- lav_export_check(lav)
  lav_msg_stop(gettext("this function needs revision"))
}

lav_export_sem <- function(lav) {
  lav <- lav_export_check(lav)
  lav_msg_stop(gettext("this function needs revision"))
}

lav_export_openmx <- function(lav) {
  lav <- lav_export_check(lav)
  lav_msg_stop(gettext("this function needs revision"))
}

# lav_options specific per estimator in separate functions LDW 06/04/2024

lav_options_est_ml <- function(opt) {
  # ML and friends: MLF, MLM, MLMV, MLMVS, MLR                     ####
  # se
  if (opt$se == "bootstrap" &&
      opt$estimator %in% c("mlf", "mlm", "mlmv", "mlmvs", "mlr")) {
    lav_msg_stop(gettext("use ML estimator for bootstrap"))
  } else if (opt$se == "default") {
    if (opt$estimator %in% c("ml", "mlf")) {
      opt$se <- "standard"
    } else if (opt$estimator %in% c("mlm", "mlmv", "mlmvs")) {
      opt$se <- "robust.sem"
    } else if (opt$estimator == "mlr") {
      opt$se <- "robust.huber.white"
    }
  } else if (opt$se == "robust") {
    if (opt$missing %in% c("ml", "ml.x")) {
      opt$se <- "robust.huber.white"
    } else if (opt$missing == "two.stage") { # needed?
      opt$se <- "two.stage"
    } else if (opt$missing == "robust.two.stage") { # needed?
      opt$se <- "robust.two.stage"
    } else {
      opt$se <- "robust.sem"
    }
  }
  # information
  if (opt$estimator == "mlf") {
    if (opt$information[1] == "default") {
      opt$information[1] <- "first.order"
    }
    if (length(opt$information) > 1L &&
        opt$information[2] == "default") {
      opt$information[2] <- "first.order"
    }
  }
  # test
  if (!opt$test[1] == "none") {
    if (opt$estimator %in% c("ml", "mlf")) {
      if (opt$test[1] == "default") {
        opt$test <- "standard"
      } # else {
      #    opt$test <- union("standard", opt$test)
      # }
    } else if (opt$estimator == "mlm") {
      if (opt$test[1] == "default") {
        opt$test <- "satorra.bentler"
      } else {
        opt$test <- union("satorra.bentler", opt$test)
      }
    } else if (opt$estimator == "mlmv") {
      if (opt$test[1] == "default") {
        opt$test <- "scaled.shifted"
      } else {
        opt$test <- union("scaled.shifted", opt$test)
      }
    } else if (opt$estimator == "mlmvs") {
      if (opt$test[1] == "default") {
        opt$test <- "mean.var.adjusted"
      } else {
        opt$test <- union("mean.var.adjusted", opt$test)
      }
    }
  }
  opt
}

lav_options_est_gls <- function(opt) {
  # GLS                                                            ####
  # FIXME: catch categorical, clustered, ...
  # se
  if (opt$se == "default") {
    opt$se <- "standard"
  }
  # test
  if (opt$test[1] == "default") {
    opt$test <- "standard"
  }
  bad.idx <- which(!opt$test %in% c(
    "standard", "none",
    "browne.residual.nt", # == standard
    "browne.residual.nt.model",
    "browne.residual.adf",
    "browne.residual.adf.model"
  ))
  if (length(bad.idx) > 0L) {
    lav_msg_stop(gettextf(
      "invalid value(s) in test= argument when estimator is GLS: %s.",
      paste(opt$test[bad.idx], collapse = " ")))
  }
  # missing
  opt$missing <- "listwise" # also pairwise?
  opt
}

lav_options_est_ntrls <- function(opt) {
  # NTRLS (experimental)                                           ####
  # optim.gradient
  opt$optim.gradien <- "numerical"
  # se
  if (opt$se == "default") {
    opt$se <- "standard"
  }
  # test
  if (opt$test[1] == "default") {
    opt$test <- "standard"
  }
  bad.idx <- which(!opt$test %in% c(
    "standard", "none",
    "browne.residual.nt",
    "browne.residual.nt.model",
    "browne.residual.adf",
    "browne.residual.adf.model"
  ))
  if (length(bad.idx) > 0L) {
    lav_msg_stop(gettextf(
      "invalid value(s) in test= argument when estimator is NTRLS: %s.",
      paste(opt$test[bad.idx], collapse = " ")))
  }
  # missing
  opt$missing <- "listwise"
  opt
}

lav_options_est_catml <- function(opt) {
  # catML (experimental)                                           ####
  # optim.gradient
  opt$optim.gradient <- "numerical" # for now
  # force correlation = TRUE, and categorical = FALSE
  opt$correlation <- TRUE
  opt$.categorical <- FALSE # we 'pretend' to have continuous data!
  # se
  if (opt$se == "default") {
    opt$se <- "robust.sem" # for now
  }
  # test
  if (opt$test[1] == "default") {
    opt$test <- "satorra.bentler"
  }
  # missing
  if (opt$missing %in% c("listwise", "pairwise")) {
    # nothing to do
  } else if (opt$missing == "default") {
    opt$missing <- "listwise"
  } else {
    lav_msg_stop(gettext(
      "missing argument should be listwise or pairwise if estimator is catML"))
  }
  opt
}

lav_options_est_wls <- function(opt) {
  # WLS                                                            ####
  # se
  if (opt$se == "default") {
    opt$se <- "standard"
  }
  # test
  if (opt$test[1] == "default") {
    opt$test <- "standard"
  }
  bad.idx <- which(!opt$test %in% c(
    "standard", "none",
    "browne.residual.nt",
    "browne.residual.nt.model",
    "browne.residual.adf", # == standard
    "browne.residual.adf.model"
  ))
  if (length(bad.idx) > 0L) {
    lav_msg_stop(gettextf(
      "invalid value(s) in test= argument when estimator is WLS: %s.",
      paste(opt$test[bad.idx], collapse = " ")))
  }
  # missing
  # opt$missing <- "listwise" (could be pairwise)
  opt
}

lav_options_est_dls <- function(opt) {
  # DLS                                                            ####
  # se
  if (opt$se == "default") {
    opt$se <- "robust.sem"
  }
  # test
  if (opt$test[1] == "default") {
    opt$test <- "satorra.bentler"
  }
  bad.idx <- which(!opt$test %in% c(
    "standard", "none",
    "satorra.bentler",
    "browne.residual.nt", # == standard
    "browne.residual.nt.model",
    "browne.residual.adf",
    "browne.residual.adf.model"
  ))
  if (length(bad.idx) > 0L) {
    lav_msg_stop(gettextf(
      "invalid value(s) in test= argument when estimator is DLS: %s.",
      paste(opt$test[bad.idx], collapse = " ")))
  }
  # always include "satorra.bentler"
  if (opt$test[1] %in% c(
    "browne.residual.nt", "browne.residual.adf",
    "browne.residual.nt.model",
    "browne.residual.adf.model"
  )) {
    opt$test <- union("satorra.bentler", opt$test)
  }
  # missing
  opt$missing <- "listwise"
  # estimator.args
  if (is.null(opt$estimator.args)) {
    opt$estimator.args <- list(
      dls.a = 1.0, dls.GammaNT = "model",
      dls.FtimesNmin1 = FALSE
    )
  } else {
    if (is.null(opt$estimator.args$dls.a)) {
      opt$estimator.args$dls.a <- 1.0
    } else {
      stopifnot(is.numeric(opt$estimator.args$dls.a))
      if (opt$estimator.args$dls.a < 0.0 ||
          opt$estimator.args$dls.a > 1.0) {
        lav_msg_stop(gettext(
          "dls.a value in estimator.args must be between 0 and 1."))
      }
    }
    if (is.null(opt$estimator.args$dls.GammaNT)) {
      opt$estimator.args$dls.GammaNT <- "model"
    } else {
      stopifnot(is.character(opt$estimator.args$dls.GammaNT))
      opt$estimator.args$dls.GammaNT <-
        tolower(opt$estimator.args$dls.GammaNT)
      if (!opt$estimator.args$dls.GammaNT %in% c("sample", "model")) {
        lav_msg_stop(gettextf(
          "dls.GammaNT value in estimator.args must be either %s.",
          lav_msg_view(c("sample", "model"), log.sep = "or")))
      }
    }
    if (is.null(opt$estimator.args$dls.FtimesNminus1)) {
      opt$estimator.args$dls.FtimesNminus1 <- FALSE
    } else {
      stopifnot(is.logical(opt$estimator.args$dls.FtimesNminus1))
    }
  }
  if (opt$estimator.args$dls.GammaNT == "sample") {
    if (opt$optim.method %in% c("nlminb", "gn")) {
      # nothing to do
    } else if (opt$optim.method == "default") {
      opt$optim.method <- "gn"
    } else {
      lav_msg_stop(gettext(
        "optim.method must be either nlminb or gn if estimator is DLS."))
    }
  } else {
    if (opt$optim.method %in% c("gn")) {
      # nothing to do
    } else if (opt$optim.method == "default") {
      opt$optim.method <- "gn"
    } else if (opt$optim.method == "nlminb") {
      opt$optim.gradient <- "numerical"
    } else {
      lav_msg_stop(gettext(
        "optim.method must be either nlminb or gn if estimator is DLS."))
    }
  }
  opt
}

lav_options_est_dwls <- function(opt) {
  # DWLS, WLSM, WLSMV, WLSMVS                                      ####
  # new in 0.6-17: if !categorical, give a warning
  if (!opt$.categorical) {
    lav_msg_warn(gettextf(
      "estimator %s is not recommended for continuous data.
      Did you forget to set the ordered= argument?",
      dQuote(lav_options_estimatorgroup(opt$estimator))))
  }
  # se
  if (opt$se == "bootstrap" &&
      opt$estimator %in% c("wlsm", "wlsmv", "wlsmvs")) {
    lav_msg_stop(gettext("use (D)WLS estimator for bootstrap"))
  } else if (opt$se == "default") {
    if (opt$estimator == "dwls" && !opt$.categorical) {
      # opt$se <- "standard"
      opt$se <- "robust.sem.nt" # new in 0.6-21
    } else {
      opt$se <- "robust.sem"
    }
  } else if (opt$se == "robust") {
    opt$se <- "robust.sem"
  }
  # test
  if (!opt$test[1] == "none") {
    if (opt$estimator == "dwls") {
      if (opt$test[1] == "default" && !opt$.categorical) {
        #opt$test <- "standard"
        opt$test <- "browne.residual.nt"
        opt$standard.test <- "browne.residual.nt"
        opt$scaled.test <- "browne.residual.nt"
      } else if (opt$test[1] == "default" && opt$.categorical) {
        opt$test <- "standard" # bad choice!
      } else {
        opt$test <- union("standard", opt$test)
      }
    } else if (opt$estimator == "wlsm") {
      if (opt$test[1] == "default") {
        opt$test <- "satorra.bentler"
      } else {
        opt$test <- union("satorra.bentler", opt$test)
      }
    } else if (opt$estimator == "wlsmv") {
      if (opt$test[1] == "default") {
        opt$test <- "scaled.shifted"
      } else {
        opt$test <- union("scaled.shifted", opt$test)
      }
    } else if (opt$estimator == "wlsmvs") {
      if (opt$test[1] == "default") {
        opt$test <- "mean.var.adjusted"
      } else {
        opt$test <- union("mean.var.adjusted", opt$test)
      }
    }
  }
  opt
}

lav_options_est_uls <- function(opt) {
  # ULS, ULSM, ULSMV, ULSMVS                                       ####
  # se
  if (opt$se == "bootstrap" &&
      opt$estimator %in% c("ulsm", "ulsmv", "ulsmvs")) {
    lav_msg_stop(gettext("use ULS estimator for bootstrap"))
  } else if (opt$se == "default") {
    if (opt$estimator == "uls" && !opt$.categorical) {
      #opt$se <- "standard"
      opt$se <- "robust.sem.nt" # new in 0.6-21
    } else {
      opt$se <- "robust.sem"
    }
  } else if (opt$se == "robust") {
    opt$se <- "robust.sem"
  }
  # test
  if (!opt$test[1] == "none") {
    if (opt$estimator == "uls") {
      if (opt$test[1] == "default" && !opt$.categorical) {
        opt$test <- "browne.residual.nt" # new in 0.6-21
        opt$standard.test <- "browne.residual.nt"
        opt$scaled.test <- "browne.residual.nt"
      } else if (opt$test[1] == "default" && opt$.categorical) {
        opt$test <- "standard"
      } else {
        opt$test <- union("standard", opt$test)
      }
    } else if (opt$estimator == "ulsm") {
      if (opt$test[1] == "default") {
        opt$test <- "satorra.bentler"
      } else {
        opt$test <- union("satorra.bentler", opt$test)
      }
    } else if (opt$estimator == "ulsmv") {
      if (opt$test[1] == "default") {
        opt$test <- "scaled.shifted"
      } else {
        opt$test <- union("scaled.shifted", opt$test)
      }
    } else if (opt$estimator == "ulsmvs") {
      if (opt$test[1] == "default") {
        opt$test <- "mean.var.adjusted"
      } else {
        opt$test <- union("mean.var.adjusted", opt$test)
      }
    }
  }
  opt
}

lav_options_est_pml <- function(opt) {
  # PML                                                            ####
  # se
  if (opt$se == "default") {
    opt$se <- "robust.huber.white"
  }

  # information
  opt$information[1] <- "observed"
  if (length(opt$information) > 1L &&
      opt$information[2] == "default") {
    opt$information[2] <- "observed"
  }
  if (length(opt$observed.information) > 1L &&
      opt$observed.information[2] == "default") {
    opt$observed.information[2] <- "hessian"
  }

  # test
  if (length(opt$test) > 1L) {
    lav_msg_stop(gettext(
      "only a single test statistic is allow when estimator is PML."))
  }
  if (!opt$test[1] == "none") {
    opt$test <- "mean.var.adjusted"
  }
  opt
}

lav_options_est_fml <- function(opt) {
  # FML - UMN                                                      ####
  # optim.gradient
  opt$optim.gradient <- "numerical"
  # se
  if (opt$se == "default") {
    opt$se <- "standard"
  }
  # information
  opt$information[1] <- "observed"
  if (length(opt$information) > 1L &&
      opt$information[2] == "default") {
    opt$information[2] <- "observed"
  }
  # test
  if (!opt$test[1] == "none") {
    opt$test <- "standard"
  }
  opt
}

lav_options_est_reml <- function(opt) {
  # REML                                                           ####
  # se
  if (opt$se == "default") {
    opt$se <- "standard"
  }
  # information
  opt$information[1] <- "observed"
  if (length(opt$information) > 1L &&
      opt$information[2] == "default") {
    opt$information[2] <- "observed"
  }
  # test
  if (!opt$test[1] == "none") {
    opt$test <- "standard"
  }
  # missing
  opt$missing <- "listwise"
  opt
}

lav_options_est_mml <- function(opt) {
  # MML                                                            ####
  # se
  if (opt$se == "default") {
    opt$se <- "standard"
  }
  # information
  opt$information[1] <- "observed"
  opt$meanstructure <- TRUE
  if (length(opt$information) > 1L &&
      opt$information[2] == "default") {
    opt$information[2] <- "observed"
  }
  # test
  opt$test <- "none"
  # link
  if (opt$link == "default") {
    # opt$link <- "logit"
    opt$link <- "probit"
  } else if (opt$link %in% c("logit", "probit")) {
    # nothing to do
  } else {
    lav_msg_stop(gettext("link must be `logit' or `probit'"))
  }
  # parameterization
  if (opt$parameterization == "default") {
    opt$parameterization <- "mml"
  } else {
    lav_msg_stop(gettext(
      "parameterization argument is ignored if estimator = MML"))
  }
  opt
}

lav_options_est_fabin <- function(opt) {
  # FABIN, MULTIPLE-GROUP-METHOD (MGM), BENTLER1982, ...           ####
  # experimental, for cfa or sam only
  # se
  if (opt$se == "default") {
    opt$se <- "none"
  }
  # bounds
  if (!is.null(opt$bounds) && opt$bounds == "default" &&
      length(opt$optim.bounds) == 0L) {
    opt$bounds <- "standard"
  }
  # test
  if (opt$test == "default") {
    opt$test <- "none" # for now
  }
  # missing
  opt$missing <- "listwise" # for now (until we have two-stage working)
  # options for fabin
  if (lav_options_estimatorgroup(opt$estimator) %in% c("FABIN2", "FABIN3")) {
    if (is.null(opt$estimator.args)) {
      opt$estimator.args <- list(thetapsi.method = "GLS")
    } else {
      if (is.null(opt$estimator.args$thetapsi.method)) {
        opt$estimator.args$thetapsi.method <- "GLS"
      } else {
        opt$estimator.args$thetapsi.method <-
          toupper(opt$estimator.args$thetapsi.method)
        if (opt$estimator.args$thetapsi.method %in% c(
          "ULS",
          "GLS", "WLS", "ULS.ML", "GLS.ML", "WLS.ML"
        )) {
          if (opt$estimator.args$thetapsi.method == "WLS") {
            opt$estimator.args$thetapsi.method <- "GLS"
          }
          if (opt$estimator.args$thetapsi.method == "WLS.ML") {
            opt$estimator.args$thetapsi.method <- "GLS.ML"
          }
        } else {
          lav_msg_stop(gettextf(
            "unknown value for estimator.args$thetapsi.method option: %s.",
            opt$estimator.args$thetapsi.method))
        }
      }
    }
  }
  # options for Bentler
  if (lav_options_estimatorgroup(opt$estimator) == "BENTLER1982") {
    if (is.null(opt$estimator.args)) {
      opt$estimator.args <- list(GLS = FALSE, quadprog = FALSE)
    } else {
      if (is.null(opt$estimator.args$GLS)) {
        opt$estimator.args$GLS <- FALSE
      }
      if (is.null(opt$estimator.args$quadprog)) {
        opt$estimator.args$quadprog <- FALSE
      }
    }
  }
  # options for guttman1952 multiple group method
  if (lav_options_estimatorgroup(opt$estimator) == "MGM") {
    if (is.null(opt$estimator.args)) {
      opt$estimator.args <- list(
        zero.after.efa = TRUE,
        psi.mapping = FALSE,
        quadprog = FALSE
      )
    } else {
      if (is.null(opt$estimator.args$zero.after.efa)) {
        opt$estimator.args$zero.after.efa <- TRUE
      }
      if (is.null(opt$estimator.args$psi.mapping)) {
        opt$estimator.args$psi.mapping <- FALSE
      }
      if (is.null(opt$estimator.args$quadprog)) {
        opt$estimator.args$quadprog <- FALSE
      }
    }
  }
  # brute-force override
  opt$optim.method <- "noniter"
  opt$start <- "simple"
  opt
}

lav_options_est_iv <- function(opt) {
  # (MI)IV-2SLS and friends                                          ####

  # brute-force override
  opt$optim.method <- "noniter"
  opt$marker.int.zero <- TRUE

  # se
  if (opt$se == "default") {
    opt$se <- "standard" # for now
  }
  # bounds
  if (!is.null(opt$bounds) && opt$bounds == "default" &&
      length(opt$optim.bounds) == 0L) {
    opt$bounds <- "standard"
  }
  # test
  if (opt$test == "default") {
    opt$test <- "browne.residual.nt" # sample-based (especially for baseline)
  }
  opt$standard.test <- opt$test

  # missing
  opt$missing <- "listwise" # for now

  # estimator options
  if (is.null(opt$estimator.args)) {
    # create default list
    opt$estimator.args <- list(iv.method = "2SLS",
                               iv.samplestats = FALSE,
                               iv.varcov.method = "RLS",
                               iv.varcov.se = TRUE,
                               iv.varcov.modelbased = TRUE)
  } else {
    if (is.null(opt$estimator.args$iv.method)) {
      opt$estimator.args$iv.method <- "2SLS"
    } else if (!opt$estimator.args$iv.method %in% "2SLS") {
      lav_msg_stop(gettext("iv.method should be 2SLS (for now)."))
    }
    if (is.null(opt$estimator.args$iv.samplestats)) {
      opt$estimator.args$iv.samplestats <- FALSE
    }
    if (opt$.categorical) {
      opt$estimator.args$iv.samplestats <- TRUE
    }
    if (is.null(opt$estimator.args$iv.varcov.method)) {
      opt$estimator.args$iv.varcov.method <- "RLS"
    } else if (!opt$estimator.args$iv.varcov.method %in%
               c("ULS", "GLS", "2RLS", "RLS")) {
      lav_msg_stop(gettext("iv.varcov.method should ULS, GLS, 2RLS or RLS."))
    }
    if (is.null(opt$estimator.args$iv.varcov.se)) {
      opt$estimator.args$iv.varcov.se <- TRUE
    }
    if (is.null(opt$estimator.args$iv.varcov.modelbased)) {
      opt$estimator.args$iv.varcov.modelbased <- TRUE
    }
  }

  opt
}

lav_options_est_none <- function(opt) {
  # NONE                                                           ####
  # se
  if (opt$se == "default") {
    opt$se <- "none"
  }
  # test
  if (opt$test[1] == "default") {
    opt$test <- "none"
  }
  opt
}

lav_model_gradient_mml <- function(lavmodel = NULL,
                                   THETA = NULL,
                                   TH = NULL,
                                   GLIST = NULL,
                                   group = 1L,
                                   lavdata = NULL,
                                   sample.mean = NULL,
                                   sample.mean.x = NULL,
                                   lavcache = NULL) {
  if (lavmodel@link == "logit") {
    lav_msg_stop(gettext("logit link not implemented yet; use probit"))
  }

  # shortcut
  ov.y.dummy.ov.idx <- lavmodel@ov.y.dummy.ov.idx[[group]]
  ov.x.dummy.ov.idx <- lavmodel@ov.x.dummy.ov.idx[[group]]
  ov.y.dummy.lv.idx <- lavmodel@ov.y.dummy.lv.idx[[group]]
  ov.x.dummy.lv.idx <- lavmodel@ov.x.dummy.lv.idx[[group]]
  ov.dummy.idx <- c(ov.y.dummy.ov.idx, ov.x.dummy.ov.idx)
  lv.dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx)
  th.idx <- lavmodel@th.idx[[group]]
  num.idx <- lavmodel@num.idx[[group]]
  ord.idx <- unique(th.idx[th.idx > 0L])


  # data for this group
  X <- lavdata@X[[group]]
  nobs <- nrow(X)
  nvar <- ncol(X)
  eXo <- lavdata@eXo[[group]]

  # MLIST (for veta and yhat)
  mm.in.group <- 1:lavmodel@nmat[group] + cumsum(c(0, lavmodel@nmat))[group]
  MLIST <- GLIST[mm.in.group]

  # quadrature points
  GH <- lavcache[[group]]$GH
  nGH <- nrow(GH$x)
  nfac <- ncol(GH$x)

  # compute VETAx (latent lv only)
  # VETAx <- lav_lisrel_vetax(MLIST = MLIST, lv.dummy.idx = lv.dummy.idx)
  VETAx <- lav_lisrel_vetax(MLIST = MLIST)
  # check for negative values?
  if (any(diag(VETAx) < 0)) {
    lav_msg_warn(gettext("--- VETAx contains negative values"))
    print(VETAx)
    return(0)
  }

  # cholesky?
  # if(is.null(lavmodel@control$cholesky)) {
  CHOLESKY <- TRUE
  # } else {
  #    CHOLESKY <- as.logical(lavmodel@control$cholesky)
  # if(nfac > 1L && !CHOLESKY) {
  #    warning("lavaan WARNING: CHOLESKY is OFF but nfac > 1L")
  # }
  # }

  if (!CHOLESKY) {
    # we should still 'scale' the factors, if std.lv=FALSE
    ETA.sd <- sqrt(diag(VETAx))
  } else {
    # cholesky takes care of scaling
    ETA.sd <- rep(1, nfac)
    tchol.VETA <- try(chol(VETAx), silent = TRUE)
    if (inherits(tchol.VETA, "try-error")) {
      lav_msg_warn(gettext("--- VETAx not positive definite"))
      print(VETAx)
      return(0)
    }
    if (!is.null(MLIST$alpha) || !is.null(MLIST$gamma)) {
      EETAx <- lav_lisrel_eetax(
        MLIST = MLIST, eXo = eXo, N = nobs,
        sample.mean = sample.mean,
        ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
        ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
        ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
        ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
      )
      # if(length(lv.dummy.idx) > 0L) {
      #    EETAx <- EETAx[,-lv.dummy.idx,drop=FALSE]
      # }
    }
  }

  # prepare common stuff
  # fix Lambda?
  LAMBDA <- lav_lisrel_lambda(
    MLIST = MLIST,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
  )

  # fix ALPHA
  ALPHA <- MLIST$alpha
  if (is.null(ALPHA)) {
    ALPHA <- numeric(nfac)
  } else if (length(lv.dummy.idx)) {
    ALPHA <- ALPHA[-lv.dummy.idx, , drop = FALSE]
  }

  # Beta?
  BETA <- MLIST$beta
  if (is.null(BETA)) {
    LAMBDA..IB.inv <- LAMBDA
  } else {
    tmp <- -BETA
    nr <- nrow(BETA)
    i <- seq_len(nr)
    tmp[cbind(i, i)] <- 1
    IB.inv <- solve(tmp)
    LAMBDA..IB.inv <- MLIST$lambda %*% IB.inv ## no need to FIX???
    if (length(lv.dummy.idx) > 0L) {
      LAMBDA..IB.inv <- LAMBDA..IB.inv[, -lv.dummy.idx, drop = FALSE]
    }

    # fix BETA
    if (length(lv.dummy.idx)) {
      BETA <- MLIST$beta[-lv.dummy.idx, -lv.dummy.idx, drop = FALSE]
    }
    tmp <- -BETA
    nr <- nrow(BETA)
    i <- seq_len(nr)
    tmp[cbind(i, i)] <- 1
    IB.inv <- solve(tmp)
  }

  # fix GAMMA
  GAMMA <- MLIST$gamma
  if (is.null(GAMMA)) {
    ALPHA.GAMMA.eXo <- matrix(as.numeric(ALPHA), nobs, nfac, byrow = TRUE)
  } else if (length(lv.dummy.idx)) {
    GAMMA <- GAMMA[-lv.dummy.idx, , drop = FALSE]
    ALPHA.GAMMA.eXo <- sweep(eXo %*% t(GAMMA),
      MARGIN = 2, STATS = as.numeric(ALPHA), FUN = "+"
    )
  }

  # Delta
  ## DD <- lavcache[[group]]$DD
  DD <- lav_model_gradient_DD(lavmodel, GLIST = GLIST, group = group)

  ## FIXME!!! do this analytically...
  x <- lav_model_get_parameters(lavmodel = lavmodel, GLIST = MLIST)
  dVetadx <- function(x, lavmodel = lavmodel, g = 1L) {
    GLIST <- lav_model_x2glist(lavmodel, x = x, type = "free")
    VETAx <- lav_model_vetax(lavmodel, GLIST = GLIST)[[g]]
    if (CHOLESKY) {
      S <- chol(VETAx) ### FIXME or t(chol())????
    } else {
      S <- diag(sqrt(diag(VETAx)))
    }
    S
  }
  Delta.S <- lav_func_jacobian_simple(func = dVetadx, x = x, lavmodel = lavmodel, g = group)
  DD$S <- Delta.S

  # compute dL/dx for each node
  # dLdx <-  matrix(0, nGH, lavmodel@nx.free)
  dFYp <- matrix(0, nobs, lavmodel@nx.free)
  SUM.LOG.FY <- matrix(0, nrow = nGH, ncol = nobs)
  for (q in 1:nGH) {
    # contribution to dFYp for this q
    dFYp.q <- matrix(0, nobs, lavmodel@nx.free)

    # current value(s) for ETA
    eta <- ksi <- GH$x[q, , drop = FALSE]

    # rescale/unwhiten
    if (CHOLESKY) {
      eta <- eta %*% tchol.VETA
    } else {
      # no unit scale? (un-standardize)
      eta <- sweep(eta, MARGIN = 2, STATS = ETA.sd, FUN = "*")
    }

    # eta_i = alpha + BETA eta_i + GAMMA eta_i + error
    #
    # - direct effect of BETA is already in VETAx, and hence tchol.VETA
    # - need to add alpha, and GAMMA eta_i
    if (!is.null(MLIST$alpha) || !is.null(MLIST$gamma)) {
      eta <- sweep(EETAx, MARGIN = 2, STATS = eta, FUN = "+")
    }

    # again, compute yhat for this node (eta)
    if (lavmodel@conditional.x) {
      yhat <- lav_lisrel_eyetax(
        MLIST = MLIST, eXo = eXo,
        ETA = eta, sample.mean = sample.mean,
        ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
        ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
        ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
        ov.x.dummy.lv.idx = ov.x.dummy.lv.idx
      )
    } else {
      yhat <- lav_lisrel_eyetax3(
        MLIST = MLIST,
        ETA = eta, sample.mean = sample.mean,
        mean.x = sample.mean.x,
        ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[group]],
        ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[group]],
        ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[group]],
        ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[group]]
      )
    }

    # compute fy.var, for this node (eta): P(Y_i =  y_i | eta_i, x_i)
    log.fy.var <- lav_predict_fy_internal(
      X = X, yhat = yhat,
      TH = TH, THETA = THETA,
      num.idx = num.idx, th.idx = th.idx,
      link = lavmodel@link, log. = TRUE
    )

    # if log, fy is just the sum of log.fy.var
    log.fy <- apply(log.fy.var, 1L, sum)

    # store log likelihoods for this node
    SUM.LOG.FY[q, ] <- log.fy

    # FY
    FY <- exp(log.fy.var) ### FIXME log/exp/log/...
    LIK.eta <- apply(FY, 1, prod)
    # fyp <- LIK.eta * GH$w[q]

    ######### dFY_p ###########################################
    # note, dFYp is actually 1/FY[,p] * dFYp

    PRE <- matrix(0, nobs, nvar)
    if (length(num.idx) > 0L) {
      tmp <- X[, num.idx, drop = FALSE] - yhat[, num.idx, drop = FALSE]
      theta.var <- diag(THETA)[num.idx]
      PRE[, num.idx] <- sweep(tmp, MARGIN = 2, STATS = 1 / theta.var, FUN = "*")
    }

    if (length(ord.idx) > 0L) {
      for (p in ord.idx) {
        # just in case we need theta[v,v] after all...
        sd.v.inv <- 1 / sqrt(THETA[p, p])

        # lav_probit
        y <- X[, p]
        th.y <- TH[th.idx == p]
        TH.Y <- c(-Inf, th.y, Inf)
        ncat <- length(th.y) + 1L
        nth <- ncat - 1L
        Y1 <- matrix(1:nth, nobs, nth, byrow = TRUE) == y
        Y2 <- matrix(1:nth, nobs, nth, byrow = TRUE) == (y - 1L)
        z1 <- pmin(100, TH.Y[y + 1L] - yhat[, p])
        z2 <- pmax(-100, TH.Y[y + 1L - 1L] - yhat[, p])
        p1 <- dnorm(z1)
        p2 <- dnorm(z2)
        # probits = p1 - p2

        PRE[, p] <- -1 * (p1 - p2) * sd.v.inv * (1 / FY[, p])

        # [nobx * n.th]
        # dth <- -1 * (Y2*p2 - Y1*p1) * sd.v.inv
        dth <- -1 * (Y2 * p2 - Y1 * p1) * sd.v.inv * (1 / FY[, p])
        dFYp.q <- dFYp.q +
          (dth %*% DD$tau[which(th.idx == p), , drop = FALSE])
      }
    }

    if (length(num.idx) > 0L) {
      # THETA (num only)
      dsigma2 <- sweep(0.5 * PRE[, num.idx] * PRE[, num.idx],
        MARGIN = 2,
        STATS = 1 / (2 * theta.var), FUN = "-"
      )
      dFYp.q <- dFYp.q + (dsigma2 %*% DD$theta)

      # NU (num only)
      dnu <- PRE[, num.idx]
      dFYp.q <- dFYp.q + (dnu %*% DD$nu)
    }

    # LAMBDA
    if (nrow(eta) == 1L) {
      dlambda <- PRE %*% eta
      ### FIXME!!!!!
    } else {
      dlambda <- matrix(apply(PRE, 2, function(x) x * eta), nobs, )
      # dlambda <- sweep(PRE, MARGIN=1, STATS=eta, FUN="*")
    }
    dFYp.q <- dFYp.q + (dlambda %*% DD$lambda)

    # PSI
    # if(nrow(ksi) == 1L) {
    dpsi <- PRE %*% kronecker(LAMBDA[, , drop = FALSE], ksi)
    # } else {
    #    dpsi <- PRE * kronecker(LAMBDA[,,drop=FALSE], ksi)
    # }
    dFYp.q <- dFYp.q + (dpsi %*% DD$S)

    # KAPPA
    if (length(ov.y.dummy.ov.idx) > 0L) {
      dkappa <- matrix(apply(
        PRE[, ov.y.dummy.ov.idx, drop = FALSE], 2,
        function(x) x * eXo
      ), nobs, )
      dFYp.q <- dFYp.q + (dkappa %*% DD$kappa)
    }

    # GAMMA
    if (!is.null(eXo)) {
      dgamma <- matrix(apply(
        PRE %*% LAMBDA..IB.inv, 2,
        function(x) x * eXo
      ), nobs, )
      dFYp.q <- dFYp.q + (dgamma %*% DD$gamma)
    }

    # BETA
    if (!is.null(BETA)) {
      # tmp <- kronecker(LAMBDA, ALPHA.GAMMA.eXo) %*%
      #         t( kronecker(t(IB.inv), IB.inv) )
      # dbeta <- apply(matrix(as.numeric(PRE) * tmp, nobs, ), 1, sum)
      dbeta <- matrix(apply(
        PRE %*% LAMBDA..IB.inv, 2,
        function(x) x * ALPHA.GAMMA.eXo
      ), nobs, )
      dFYp.q <- dFYp.q + (dbeta %*% DD$beta)
    }

    dFYp <- dFYp + ((LIK.eta * GH$w[q]) * dFYp.q)
  }

  lik <- as.numeric(t(GH$w) %*% exp(SUM.LOG.FY))
  # avoid underflow
  idx <- which(lik < exp(-600))
  if (length(idx) > 0L) {
    lik[idx] <- exp(-600)
  }

  dFYp <- 1 / lik * dFYp

  dx <- apply(dFYp, 2, sum)

  # integration
  # dx <- apply(as.numeric(GH$w) * dLdx, 2, sum)

  # minimize
  dx <- -1 * dx

  dx
}

# Albert (1944a/b) & Ihara & Kano 1986 method to estimate residual variances
# of indicators using a PArtitioned Covariance matrix Estimator (PACE)
#
# The implementation is based on Cudeck 1991:

# Cudeck, R. (1991). Noniterative factor analysis estimators, with algorithms
# for subset and instrumental variable selection. Journal of Educational
# Statistics, 16(1), 35-52.

# YR -- 14 FEB 2020

# - 'fast' version; only (2*nfactors + 1) iterations are needed
# - scale-invariant (by default)
# - always assuming unit variances for the factors
lav_efa_pace <- function(S, nfactors = 1L, p.idx = seq_len(ncol(S)),
                         reflect = TRUE, order.lv.by = "none",
                         use.R = TRUE, theta.only = TRUE) {
  S <- unname(S)
  nvar <- ncol(S)
  theta <- numeric(nvar)
  stopifnot(nfactors < nvar / 2)

  # because subset selection is not scale-invariant, we transform
  # S to R, compute theta based on R, and then rescale again
  if (use.R) {
    s.var <- diag(S)
    R <- stats::cov2cor(S)
  } else {
    R <- S
  }

  # find principal variables ('largest' sub-block)
  A <- R

  # row indices
  v.r <- integer(0L)
  # column indices
  v.c <- integer(0L)

  for (h in seq_len(nfactors)) {
    # mask
    mask.idx <- c(v.r, v.c)
    tmp <- abs(A)
    if (length(mask.idx) > 0L) {
      tmp[mask.idx, ] <- 0
      tmp[, mask.idx] <- 0
    }
    diag(tmp) <- 0

    # find maximum off-diagonal element
    idx <- which(tmp == max(tmp), arr.ind = TRUE, useNames = FALSE)[1, ]
    k <- idx[1]
    l <- idx[2]
    v.r <- c(v.r, k)
    v.c <- c(v.c, l)

    # non-symmetric sweep operator
    a.kl <- A[k, l]
    if (abs(a.kl) < sqrt(.Machine$double.eps)) {
      out <- A
      out[k, ] <- 0
      out[, l] <- 0
    } else {
      out <- A - tcrossprod(A[, l], A[k, ]) / a.kl
      out[k, ] <- A[k, ] / a.kl
      out[, l] <- -A[, l] / a.kl
      out[k, l] <- 1 / a.kl
    }
    A <- out
  }
  # diagonal elements are estimates of theta
  # for all variables not in (v.r, v.c)
  all.idx <- seq_len(nvar)
  v.r.init <- v.r
  v.c.init <- v.c
  other.idx <- all.idx[-c(v.r, v.c)]
  theta[other.idx] <- diag(A)[other.idx]


  # now fill in theta for the 2*m remaining variables in c(v.r.init, v.c.init)
  for (i in p.idx) {
    if (i %in% other.idx) {
      next
    }

    # row indices
    v.r <- integer(0L)
    # column indices
    v.c <- integer(0L)

    A <- R
    for (h in seq_len(nfactors)) {
      # mask
      mask.idx <- c(i, v.r, v.c)
      tmp <- abs(A)
      tmp[mask.idx, ] <- 0
      tmp[, mask.idx] <- 0
      diag(tmp) <- 0

      # find maximum off-diagonal element
      idx <- which(tmp == max(tmp), arr.ind = TRUE, useNames = FALSE)[1, ]
      k <- idx[1]
      l <- idx[2]
      v.r <- c(v.r, k)
      v.c <- c(v.c, l)

      # non-symmetric sweep operator
      a.kl <- A[k, l]
      if (abs(a.kl) < sqrt(.Machine$double.eps)) {
        out <- A
        out[k, ] <- 0
        out[, l] <- 0
      } else {
        out <- A - tcrossprod(A[, l], A[k, ]) / a.kl
        out[k, ] <- A[k, ] / a.kl
        out[, l] <- -A[, l] / a.kl
        out[k, l] <- 1 / a.kl
      }
      A <- out
    }

    # diagonal element is estimate of theta
    theta[i] <- A[i, i]
  }

  # return theta elements only
  if (theta.only) {
    # rescale back to S metric
    if (use.R) {
      theta <- theta * s.var
    }
    return(theta[p.idx])
  }

  # compute LAMBDA using the 'eigenvalue' method
  EV <- eigen(R, symmetric = TRUE)
  S.sqrt <- EV$vectors %*% sqrt(diag(EV$values)) %*% t(EV$vectors)
  S.inv.sqrt <- EV$vectors %*% sqrt(diag(1 / EV$values)) %*% t(EV$vectors)
  RTR <- S.inv.sqrt %*% diag(theta) %*% S.inv.sqrt

  EV <- eigen(RTR, symmetric = TRUE)
  Omega.m <- EV$vectors[, 1L + nvar - seq_len(nfactors), drop = FALSE]
  gamma.m <- EV$values[1L + nvar - seq_len(nfactors)]
  Gamma.m <- diag(gamma.m, nrow = nfactors, ncol = nfactors)

  # Cuceck 1991 page 37 bottom of the page:
  LAMBDA.dot <- S.sqrt %*% Omega.m %*% sqrt(diag(nfactors) - Gamma.m)

  if (use.R) {
    # IF (and only if) the input is a correlation matrix,
    # we must rescale so that the diag(R.implied) == 1

    # R.unscaled <- tcrossprod(LAMBDA.dot) + diag(theta)
    # r.var.inv <- 1/diag(R.unscaled)

    # LAMBDA/THETA in correlation metric
    # LAMBDA.R <- sqrt(r.var.inv) * LAMBDA.dot
    # THETA.R <- diag(r.var.inv * theta)

    # convert to 'S' metric
    LAMBDA <- sqrt(s.var) * LAMBDA.dot
    THETA <- diag(s.var * theta)
  } else {
    LAMBDA <- LAMBDA.dot
    THETA <- diag(theta)
  }

  # reflect so that column sum is always positive
  if (reflect) {
    SUM <- colSums(LAMBDA)
    neg.idx <- which(SUM < 0)
    if (length(neg.idx) > 0L) {
      LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE]
    }
  }

  # reorder the columns
  if (order.lv.by == "sumofsquares") {
    L2 <- LAMBDA * LAMBDA
    order.idx <- base::order(colSums(L2), decreasing = TRUE)
  } else if (order.lv.by == "index") {
    # reorder using Asparouhov & Muthen 2009 criterion (see Appendix D)
    max.loading <- apply(abs(LAMBDA), 2, max)
    # 1: per factor, number of the loadings that are at least 0.8 of the
    #    highest loading of the factor
    # 2: mean of the index numbers
    average.index <- sapply(seq_len(ncol(LAMBDA)), function(i) {
      mean(which(abs(LAMBDA[, i]) >= 0.8 * max.loading[i]))
    })
    # order of the factors
    order.idx <- base::order(average.index)
  } else if (order.lv.by == "none") {
    order.idx <- seq_len(ncol(LAMBDA))
  } else {
    lav_msg_stop(gettext("order must be index, sumofsquares or none"))
  }
  LAMBDA <- LAMBDA[, order.idx, drop = FALSE]

  list(LAMBDA = LAMBDA, THETA = THETA)
}

lav_beziersq_beziersc <- function(x) {
  # x contains the beziers points P1, P, P2 (P = control) for quadratic beziers
  # x is a matrix with 2 rows and 3 columns
  # returns rtval which contains P1, C1, C2, P2 so that the cubic beziers
  # with control points C1 and C2 is as 'high' as the quadratic one
  # rtval is a matrix with 2 rows and 4 columns
  matrix(c(x[ , 1L], x[ , 1L] / 3 + 2 * x[ ,2L] / 3,
         x[ , 3L] / 3 + 2 * x[ ,2L] / 3, x [ ,3L]), nrow = 2)
}
lav_node_coordinates <- function(nodeid, anker, nodes, maxrij) {
  nodenr <- which(nodes$id == nodeid)
  middelpunt <- c(nodes$kolom[nodenr], maxrij - nodes$rij[nodenr])
  delta <- switch(anker, n = c(0, 0.3), ne = c(0.3, 0.3), e = c(0.3, 0),
                  se = c(0.3, -0.3), s = c(0, -0.3), sw = c(-0.3, -0.3),
                  w = c(-0.3, 0), nw = c(-0.3, 0.3))
  middelpunt + delta
}
lav_plotinfo_tikzcode <- function(plotinfo,
                          outfile = "",
                          cex = 1.3,
                          sloped.labels = TRUE,
                          standalone = FALSE,
                          mlovcolors = c("lightgreen", "lightblue"),
                          lightness = 1,
                          italic = TRUE,
                          auto.subscript = TRUE
                          ) {
  tmpcol <- col2rgb(mlovcolors)
  wovcol <- paste(round(tmpcol[, 1L]/255, 2), collapse = ",")
  bovcol <- paste(round(tmpcol[, 2L]/255, 2), collapse = ",")
  nodenaam <- function(nm, blk) {
    if (blk > 0L) return(gsub("_", "", paste0("B", blk, nm)))
    return(gsub("_", "", nm))
    }
  mlrij <- plotinfo$mlrij
  if (is.null(mlrij))
    lav_msg_stop(gettext(
      "plotinfo hasn't been processed by lav_plotinfo_positions!"))
  nodes <- plotinfo$nodes
  edges <- plotinfo$edges
  if (lightness != 1) {
    mlrij <- lightness * mlrij
    nodes$kolom <- lightness * nodes$kolom
    nodes$rij <- lightness * nodes$rij
    edges$controlpt.kol <- lightness * edges$controlpt.kol
    edges$controlpt.rij <- lightness * edges$controlpt.rij
  }
  if (is.character(outfile)) {
    zz <- file(outfile, open = "w")
    closezz <- TRUE
  } else {
    zz <- outfile
    closezz <- FALSE
  }
  if (standalone) writeLines(c(
    "\\documentclass{article}",
    "\\usepackage{amsmath, amssymb}",
    "\\usepackage{amsfonts}",
    "\\usepackage[utf8]{inputenc}",
    "\\usepackage[english]{babel}",
    "\\usepackage{color}",
    "\\usepackage{tikz}"), zz)
  commstyle <- paste0("draw, minimum size=", round(6 * cex), "mm")
  writeLines (c(
    "\\usetikzlibrary {shapes.geometric}",
    paste0("\\definecolor{wovcol}{rgb}{", wovcol, "}"),
    paste0("\\definecolor{bovcol}{rgb}{", bovcol, "}"),
    "\\tikzset{",
    ">=stealth,",
    paste0("x={(", cex, "cm,0cm)}, y={(0cm,", cex, "cm)},"),
    paste0("lv/.style={circle, ", commstyle, ", thick},"),
    paste0("varlv/.style={circle, draw, minimum size=", round(4 * cex), "mm, semithick},"),
    paste0("cv/.style={regular polygon, regular polygon sides=6, ", commstyle, ", thick},"),
    paste0("ov/.style={rectangle, ", commstyle,", thick},"),
    paste0("wov/.style={rectangle, rounded corners, fill=wovcol, ", commstyle, ", thick},"),
    paste0("bov/.style={rectangle, rounded corners, fill=bovcol, ", commstyle, ", thick},"),
    paste0("const/.style={regular polygon, regular polygon sides=3, ", commstyle, ", thick}"),
    "}"), zz)
  if (standalone) writeLines("\\begin{document}", zz)
  writeLines("\\begin{tikzpicture}", zz)
  maxrij <- max(nodes$rij)
  maxcol <- max(nodes$kolom)
  if (mlrij > 0L) {
    writeLines(paste("\\draw (0, ", maxrij - mlrij, ") -- (", maxcol, ",", maxrij - mlrij,
    ");", sep = ""), zz)
  }
  for (j in seq.int(nrow(nodes))) {
    xpos <- nodes$kolom[j]
    ypos <- maxrij - nodes$rij[j]
    writeLines(paste(
      "\\node[", nodes$tiepe[j], "] (", nodenaam(nodes$naam[j], nodes$blok[j]),
      ") at (", xpos, ",", ypos, ") {",
      lav_label_code(nodes$naam[j], italic = italic,
                    auto.subscript = auto.subscript)$tikz, "};", sep = ""), zz)
  }
  varlv <-any(nodes$tiepe == "varlv")
  for (j in seq.int(nrow(edges))) {
    van <- which(nodes$id == edges$van[j])
    vannaam <- nodenaam(nodes$naam[van], nodes$blok[van])
    naar <- which(nodes$id == edges$naar[j])
    naarnaam <- nodenaam(nodes$naam[naar], nodes$blok[naar])
    nodelabel <- lav_label_code(edges$label[j], italic = italic,
                                  auto.subscript = auto.subscript)$tikz
    if (van == naar) { # self
      if (nodes$kolom[van] == 1L) {
        writeLines(paste("\\path[<->] (", vannaam,
                         ") edge [in=160, out=-160, looseness=8] node[right] {",
                         nodelabel, "} (",
                         vannaam, ");",
                         sep = ""), zz)
      } else if (nodes$rij[van] == maxrij) {
        writeLines(paste("\\path[<->] (", vannaam,
                         ") edge [in=-110, out=-70, looseness=8] node[above] {",
                         nodelabel, "} (",
                         vannaam, ");",
                         sep = ""), zz)
      } else if (nodes$kolom[van] == maxcol) {
        writeLines(paste("\\path[<->] (", vannaam,
                         ") edge [in=20, out=-20, looseness=8] node[left] {",
                         nodelabel, "} (",
                         vannaam, ");",
                         sep = ""), zz)
      } else {
        writeLines(paste("\\path[<->] (", vannaam,
                         ") edge [in=110, out=70, looseness=8] node[below] {",
                         nodelabel, "} (",
                         vannaam, ");",
                         sep = ""), zz)
      }
    } else {
      anchorv <- switch(edges$vananker[j],
                        n = ".north", e = ".east", s = ".south", w = ".west")
      anchorn <- switch(edges$naaranker[j],
                        n = ".north", e = ".east", s = ".south", w = ".west")
      if (is.na(edges$controlpt.kol[j])) {
        pathtype <- " -- "
      } else {
        vanadr <- lav_node_coordinates(edges$van[j], edges$vananker[j], nodes, maxrij)
        naaradr <- lav_node_coordinates(edges$naar[j], edges$naaranker[j], nodes, maxrij)
        controlq <- c(edges$controlpt.kol[j], maxrij - edges$controlpt.rij[j])
        beziersc <- lav_beziersq_beziersc(
          matrix(c(vanadr, controlq, naaradr), nrow = 2L)
        )
        pathtype <- paste0(" .. controls (", beziersc[1L, 2L] , ",",
                           beziersc[2L, 2L], ") and (", beziersc[1L, 3L] , ",",
                           beziersc[2L, 3L], ") .. ")
      }
      thelabel <- lav_label_code(edges$label[j], italic = italic,
                                   auto.subscript = auto.subscript)$tikz
      if (thelabel != "") {
        thelabel <- paste0("node[pos=0.5,",
                           ifelse(edges$labelbelow[j], "below", "above"),
                           ifelse(sloped.labels, ",sloped", ""),
                           "] {", thelabel, "} ")
      }
      pijl <- ifelse(edges$tiepe[j] %in% c("~~", "~~~"), "<->", "->")
      writeLines(paste0("\\draw[", pijl, "] (", vannaam, anchorv, ")",
                pathtype, "(", naarnaam, anchorn, ") ",
                thelabel, ";", sep = ""), zz)
    }
  }
  writeLines("\\end{tikzpicture}", zz)
  if(standalone) writeLines("\\end{document}", zz)
  if (closezz) close(zz)
  return(invisible(NULL))
}

# functions related to AIC and other information criteria

# lower-level functions:
# - lav_fit_aic
# - lav_fit_bic
# - lav_fit_sabic

# higher-level functions:
# - lav_fit_aic_lavobject

# Y.R. 21 July 2022

lav_fit_aic <- function(logl = NULL, npar = NULL) {
  AIC <- (-2 * logl) + (2 * npar)
  AIC
}

lav_fit_bic <- function(logl = NULL, npar = NULL, N = NULL) {
  BIC <- (-2 * logl) + (npar * log(N))
  BIC
}

lav_fit_sabic <- function(logl = NULL, npar = NULL, N = NULL) {
  N.star <- (N + 2) / 24
  SABIC <- (-2 * logl) + (npar * log(N.star))
  SABIC
}

lav_fit_aic_lavobject <- function(lavobject = NULL, fit.measures = "aic",
                                  standard.test = "standard",
                                  scaled.test = "none",
                                  estimator = "ML") {
  # check lavobject
  stopifnot(inherits(lavobject, "lavaan"))
  # check object
  lavobject <- lav_object_check_version(lavobject)

  # tests
  TEST <- lavobject@test
  test.names <- sapply(lavobject@test, "[[", "test")
  if (test.names[1] == "none" || standard.test == "none") {
    return(list())
  }
  test.idx <- which(test.names == standard.test)[1]
  if (length(test.idx) == 0L) {
    return(list())
  }

  scaled.flag <- FALSE
  if (!scaled.test %in% c("none", "standard", "default")) {
    scaled.idx <- which(test.names == scaled.test)
    if (length(scaled.idx) > 0L) {
      scaled.idx <- scaled.idx[1] # only the first one
      scaled.flag <- TRUE
    }
  }

  # estimator?
  if (missing(estimator)) {
    estimator <- lavobject@Options$estimator
  }

  # supported fit measures in this function
  if (estimator == "MML") {
    fit.logl <- c("logl", "aic", "bic", "ntotal", "bic2")
  } else {
    fit.logl <- c(
      "logl", "unrestricted.logl", "aic", "bic",
      "ntotal", "bic2"
    )
  }
  if (scaled.flag &&
    scaled.test %in% c("yuan.bentler", "yuan.bentler.mplus")) {
    fit.logl <- c(fit.logl, "scaling.factor.h1", "scaling.factor.h0")
  }

  # which one do we need?
  if (missing(fit.measures)) {
    # default set
    fit.measures <- fit.logl
  } else {
    # remove any not-CFI related index from fit.measures
    rm.idx <- which(!fit.measures %in% fit.logl)
    if (length(rm.idx) > 0L) {
      fit.measures <- fit.measures[-rm.idx]
    }
    if (length(fit.measures) == 0L) {
      return(list())
    }
  }

  # output container
  indices <- list()

  # non-ML values
  indices["logl"] <- as.numeric(NA)
  indices["unrestricted.logl"] <- as.numeric(NA)
  indices["aic"] <- as.numeric(NA)
  indices["bic"] <- as.numeric(NA)
  indices["ntotal"] <- lavobject@SampleStats@ntotal
  indices["bic2"] <- as.numeric(NA)

  if (estimator %in% c("ML", "MML")) {
    # do we have a @h1 slot?
    if (length(lavobject@h1) > 0L) {
      indices["unrestricted.logl"] <- lavobject@h1$logl$loglik
    } else {
      lavh1 <- lav_h1_implied_logl(
        lavdata = lavobject@Data,
        lavsamplestats = lavobject@SampleStats,
        lavoptions = lavobject@Options
      )
      indices["unrestricted.logl"] <- lavh1$logl$loglik
    }

    # logl H0
    loglik <- lavobject@loglik
    indices["logl"] <- loglik$loglik
    indices["aic"] <- loglik$AIC
    indices["bic"] <- loglik$BIC
    indices["ntotal"] <- loglik$ntotal
    indices["bic2"] <- loglik$BIC2

    # scaling factor for MLR
    if (scaled.test %in% c("yuan.bentler", "yuan.bentler.mplus")) {
      indices["scaling.factor.h1"] <- TEST[[scaled.idx]]$scaling.factor.h1
      indices["scaling.factor.h0"] <- TEST[[scaled.idx]]$scaling.factor.h0
    }
  } # ML

  # return only those that were requested
  indices[fit.measures]
}

# Displays a message (... concatenated with spaces in between) with header
# 'lavaan(function):', except when showheader == FALSE, and formatted to have
# a maximum line length of 'txt.width' while all but the first line start with
# 'indent' spaces. If a footer is specified it is appended to the formatted text
# 'as is'. The message is shown via R function 'message()'.
lav_msg_note <- function(..., showheader = FALSE, footer = "") {
  wat <- unlist(list(...), use.names = FALSE)
  if (!showheader) wat <- c("lavaan NOTE: ___", wat)
  msg <- lav_msg(wat, showheader = showheader)
  if (footer != "") msg <- paste(msg, footer, sep = "\n")
  message(msg, domain = NA)
}

# Displays a message with header and formatted as
# above via R function 'warning()'.
lav_msg_warn <- function(..., footer = "") {
  if (!lav_warn()) return()
  wat <- unlist(list(...), use.names = FALSE)
  msg <- lav_msg(wat)
  if (footer != "") msg <- paste(msg, footer, sep = "\n")
  warning(msg, call. = FALSE, domain = NA)
}

# Displays a message with header and formatted as
# above via R function 'stop()'.
lav_msg_stop <- function(..., footer = "") {
  wat <- unlist(list(...), use.names = FALSE)
  msg <- lav_msg(wat)
  if (footer != "") msg <- paste(msg, footer, sep = "\n")
  stop(msg, call. = FALSE, domain = NA)
}

# Displays a message with header and formatted as
# above via R function 'stop()', where the message is prepended with "FIXME:",
# to indicate an internal error, e.g. an error condition which was supposed
# to be handled in the calling functions. Such error message do not have to
# be created by [n]gettext[f] because they don't have to be translated!!!
lav_msg_fixme <- function(...) {
  wat <- c("FIXME: ", unlist(list(...), use.names = FALSE))
  stop(lav_msg(wat), call. = FALSE, domain = NA)
}

# subroutine for above functions
lav_msg <- function(wat, txt.width = getOption("width", 80L),
                    indent = 3L, showheader = TRUE) {
  if (showheader) {
    ignore.in.stack <- c(
      "^eval$", "^try", "^doTryCatch", "^lav_msg", "^stop$", "^warning$",
      "^which$", "^unique$", "^as\\.", "^unlist$", "^message$",
      "^source$", "^withVisible$", "^tryCatch.W.E$", "^withCallingHandlers$",
      "^do.call$", "^paste"
    )
    sc <- sys.calls()
    sc.i <- length(sc)
    sc.naam <- ""
    while (sc.i > 0L) {
      x <- tryCatch(
        as.character(sc[[sc.i]][[1L]]),
        error = function(e) {"unknown"}
      )
      if (length(x) == 3L) {
        # needed if a function specified in namespace, e.g.
        # as.character(str2lang("lavaan::sem(m, d)")[[1L]])
        x <- x[[3L]]
      }
      skip <- FALSE
      for (re in ignore.in.stack) {
        if (grepl(re, x)) {
          skip <- TRUE
          break
        }
      }
      if (!skip) {
        sc.naam <- x
        break
      }
      sc.i <- sc.i - 1L
    }
    if (sc.naam == "") {
      header <- "lavaan: ___"
    } else {
      header <- paste0("lavaan->", sc.naam, "(): ___")
    }
  } else {
    header <- ""
  }
  txt.width <- txt.width - indent # whitespace at the right
  # make sure we only have a single string
  txt <- paste(wat, collapse = " ")
  # split the txt in little chunks
  chunks <- strsplit(paste(header, txt), "\\s+", fixed = FALSE)[[1]]

  # chunk size (number of characters)
  chunk.size <- nchar(chunks)

  # remove empty chunk in position 1 (if txt starts with whitespace)
  if (chunk.size[1L] == 0L) {
    chunks <- chunks[-1L]
    chunk.size <- chunk.size[-1]
  }

  nstart <- 1L
  nstop <- 1L
  corr.line1 <- 7L # first line possibly contains "error: "
  while (nstart <= length(chunks)) {
    while (nstop < length(chunks) &&
           sum(chunk.size[seq.int(nstart, nstop + 1L)]) + corr.line1 +
           nstop - nstart + indent < txt.width && chunks[nstop + 1L] != "___") {
      nstop <- nstop + 1
    }
    corr.line1 <- 0L
    if (nstop < length(chunks) && chunks[nstop + 1L] == "___") {
      # forced line break
      chunks[nstop + 1L] <-  ""
      nstop <- nstop + 1L
    }
    if (nstop < length(chunks)) {
      chunks[nstop + 1L] <- paste0(
        "\n", strrep(" ", indent),
        chunks[nstop + 1L]
      )
    }
    nstart <- nstop + 1L
    nstop <- nstart
  }
  paste(chunks, collapse = " ")
}

# Transforms a value to a character representation for use in messages
# if logsep = "array" (default), letters[1:3] is transformed to ("a", "b", "c")
# if logsep = "none", c("x", "y", "z") is transformed to "x", "y", "z"
# if logsep = "and", 1:3 is transformed to 1, 2 and 3
# if logsep = "or", c("a", "b", "c") is transformed to "a", "b" or "c"
# The type of quote can be modified via parameter qd (default = TRUE).
# If the object has names, the names will be prepended with a colon before the
# value, e.g. c(x = 2.3, y = 4) --> (x : 2.3, y : 4).
lav_msg_view <- function(x,
                         log.sep = c("array", "none", "and", "or"),
                         qd = TRUE) {
  if (missing(x)) {
    return("NULL")
  }
  log.sep <- match.arg(log.sep)
  xn <- names(x)
  if (is.list(x)) {
    xx <- sapply(x, lav_msg_view)
  } else {
    if (is.character(x)) {
      if (qd) {
        xx <- dQuote(x, q = FALSE)
      } else {
        xx <- sQuote(x, q = FALSE)
      }
    } else {
      xx <- as.character(x)
    }
    xx[is.na(x)] <- "NA"
  }
  if (!is.null(xn)) xx <- paste(xn, ":", xx)
  if (length(xx) == 1) {
    rv <- xx
  } else {
    if (log.sep == "array") rv <- paste0("(", paste(xx, collapse = ", "), ")")
    if (log.sep == "none") rv <- paste(xx, collapse = ", ")
    if (log.sep == "and") rv <- paste(paste(xx[-length(xx)], collapse = ", "), gettext("and"), xx[length(xx)])
    if (log.sep == "or") rv <- paste(paste(xx[-length(xx)], collapse = ", "), gettext("or"), xx[length(xx)])
  }
  rv
}
# Warning for deprecated functions
# Like base::.Deprecated but specialised for lavaan
# parameter times specifies how many times the warning should be generated
# during one "lavaan-package-session"
lav_deprecated <- function(new,
                           old = as.character(sys.call(sys.parent()))[1L],
                           times = 1L) {
  dprmsg <-  get0(paste0("dpr_", old), lavaan_cache_env,
                  ifnotfound = as.integer(times))
  if (dprmsg <= 0L) return(invisible(NULL))
  assign(paste0("dpr_", old), dprmsg - 1L, lavaan_cache_env)
  msg <- c(gettextf("'%s' is deprecated.\n", old),
         gettextf("Use '%s' instead.\n", new),
         gettext("See help(\"Deprecated\")"))
  msg <- paste(msg, collapse = "")
  warning(warningCondition(msg, old = old, new = new, package = NULL,
                           class = "deprecatedWarning"))
}

# Warning for deprecated arguments-parameter for another parameter in a function
# method.par specifies the name of the parameter used for a 'method'
# arg.par specifies the name of the deprecated parameter
# parameter times specifies how many times the warning should be generated
# during one "lavaan-package-session"
lav_deprecated_args <- function(method.par, arg.par, times = 1L) {
  dprmsg <-  get0(paste0("dpr_", method.par, arg.par), lavaan_cache_env,
                  ifnotfound = as.integer(times))
  if (dprmsg <= 0L) return(invisible(NULL))
  assign(paste0("dpr_", method.par, arg.par), dprmsg - 1L, lavaan_cache_env)
  msg <- c(gettextf("Argument '%s' is deprecated.\n", arg.par),
         gettextf("The arguments for '%s' can now be provided in '%s' itself.\n",
          method.par, method.par))
  msg <- paste(msg, collapse = "")
  warning(warningCondition(msg, old = arg.par, new = method.par, package = NULL,
                           class = "deprecatedWarning"))
}

#  ---------------  examples of use ----------------------
# # warning if argument x is missing
#   lav_msg_warn(gettextf(
#     "argument %1$s is missing, using %2$s.",
#     x, lav_msg_view(usedvalue)
#   ))
#
# # warning if length of an argument x is greater then 1 and cannot be
#   lav_msg_warn(gettextf("%1$s argument should be a single character string.
#   Only the first one (%2$s) is used.", xname, x[[1]]))
#
# # error if argument is unknown (show value)
#   lav_msg_stop(gettextf(
#     "%1$s argument unknown: %2$s",
#     xname, lav_msg_view(xvalue)
#   ))
#
# # error if argument isn't one of the allowed values, show values allowed
#   if (length(allowed) == 2L) {
#     lav_msg_stop(gettextf(
#       "%1$s argument must be either %2$s",
#       x, lav_msg_view(allowed, "or")
#     ))
#   } else {
#     lav_msg_stop(gettextf(
#       "%1$s argument must be one of %2$s",
#       x, lav_msg_view(allowed, "or")
#     ))
#   }
#
# # error if argument isn't one of the allowed values (show invalid ones)
#   lav_msg_stop(sprintf(
#     ngettext(
#       length(invalids),
#       "invalid value in %1$s argument: %2$s.",
#       "invalid values in %1$s argument: %2$s."
#     ),
#     x, lav_msg_view(invalids, log.sep = "none")
#   ))

# routines for numerical intregration

# integrate (-infty to +infty) a product of univariate Gaussian densities
# with givens means (mus) and standard deviations (sds) (or variances, vars)
lav_integration_gaussian_product <- function(mus = NULL, sds = NULL, vars = NULL) {
  n <- length(mus)
  if (is.null(vars)) {
    vars <- sds^2
  }

  # variance product
  var.prod <- 1 / sum(1 / vars)

  # mean product
  mu.prod <- sum(mus / vars) * var.prod

  # normalization constant
  const <- 1 / sqrt((2 * pi)^(n - 1)) * sqrt(var.prod) * sqrt(1 / prod(vars)) * exp(-0.5 * (sum(mus^2 / vars) - mu.prod^2 / var.prod))

  const
}



# return Gauss-Hermite quadrature rule for given order (n)
# return list: x = nodes, w = quadrature weights
#

# As noted by Wilf (1962, chapter 2, ex 9), the nodes are given by
# the eigenvalues of the Jacobi matrix; weights are given by the squares of the
# first components of the (normalized) eigenvectors, multiplied by sqrt(pi)
#
# (This is NOT identical to Golub & Welsch, 1968: as they used a specific
#  method tailored for tridiagonal symmetric matrices)
#
# TODO: look at https://github.com/ajt60gaibb/FastGaussQuadrature.jl/blob/master/src/gausshermite.jl
# featuring the work of Ignace Bogaert (UGent)
#
# approximation of the integral of 'f(x) * exp(-x*x)' from -inf to +inf
# by sum( f(x_i) * w_i )
#
# CHECK: sum(w_i) should be always sqrt(pi) = 1.772454
lav_integration_gauss_hermite_xw <- function(n = 21L, revert = FALSE) {
  # force n to be an integer
  n <- as.integer(n)
  stopifnot(n > 0L)

  if (n == 1L) {
    x <- 0
    w <- sqrt(pi)
  } else {
    # construct symmetric, tridiagonal Jacobi matrix
    # diagonal = 0, -1/+1 diagonal is sqrt(1:(n-1)/2)
    u <- sqrt(seq.int(n - 1L) / 2) # upper diagonal of J
    Jn <- matrix(0, n, n)
    didx <- lav_matrix_diag_idx(n)
    Jn[(didx + 1)[-n]] <- u
    # Jn[(didx-1)[-1]] <- u # only lower matrix is used anyway

    # eigen decomposition
    # FIXME: use specialized function for tridiagonal symmetrix matrix
    ev <- eigen(Jn, symmetric = TRUE)
    x <- ev$values
    tmp <- ev$vectors[1L, ]
    w <- sqrt(pi) * tmp * tmp
  }

  # revert? (minus to plus)
  if (revert) {
    x <- -x
  }

  list(x = x, w = w)
}

# generate GH points + weights
lav_integration_gauss_hermite <- function(n = 21L,
                                          dnorm = FALSE,
                                          mean = 0, sd = 1,
                                          ndim = 1L,
                                          revert = TRUE,
                                          prune = FALSE) {
  XW <- lav_integration_gauss_hermite_xw(n = n, revert = revert)

  # dnorm kernel?
  if (dnorm) {
    # scale/shift x
    x <- XW$x * sqrt(2) * sd + mean

    # scale w
    w <- XW$w / sqrt(pi)
  } else {
    x <- XW$x
    w <- XW$w
  }

  if (ndim > 1L) {
    # cartesian product
    x <- as.matrix(expand.grid(rep(list(x), ndim), KEEP.OUT.ATTRS = FALSE))
    w <- as.matrix(expand.grid(rep(list(w), ndim), KEEP.OUT.ATTRS = FALSE))
    w <- apply(w, 1, prod)
  } else {
    x <- as.matrix(x)
    w <- as.matrix(w)
  }

  # prune?
  if (is.logical(prune) && prune) {
    # always divide by N=21
    lower.limit <- XW$w[1] * XW$w[floor((n + 1) / 2)] / 21
    keep.idx <- which(w > lower.limit)
    w <- w[keep.idx]
    x <- x[keep.idx, , drop = FALSE]
  } else if (is.numeric(prune) && prune > 0) {
    lower.limit <- quantile(w, probs = prune)
    keep.idx <- which(w > lower.limit)
    w <- w[keep.idx]
    x <- x[keep.idx, , drop = FALSE]
  }

  list(x = x, w = w)
}

# backwards compatibility
lav_integration_gauss_hermite_dnorm <- function(n = 21L, mean = 0, sd = 1,
                                                ndim = 1L,
                                                revert = TRUE,
                                                prune = FALSE) {
  lav_integration_gauss_hermite(
    n = n, dnorm = TRUE, mean = mean, sd = sd,
    ndim = ndim, revert = revert, prune = prune
  )
}

# plot 2-dim
# out <- lavaan:::lav_integration_gauss_hermite_dnorm(n = 20, ndim = 2)
# plot(out$x, cex = -10/log(out$w), col = "darkgrey", pch=19)

# integrand g(x) has the form g(x) = f(x) dnorm(x, m, s^2)
lav_integration_f_dnorm <- function(func = NULL, # often ly.prod
                                    dnorm.mean = 0, # dnorm mean
                                    dnorm.sd = 1, # dnorm sd
                                    XW = NULL, # GH points
                                    n = 21L, # number of nodes
                                    adaptive = FALSE, # adaptive?
                                    iterative = FALSE, # iterative?
                                    max.iter = 20L, # max iterations
                                    ...) { # optional args for 'f'

  # create GH rule
  if (is.null(XW)) {
    XW <- lav_integration_gauss_hermite_xw(n = n, revert = TRUE)
  }

  if (!adaptive) {
    w.star <- XW$w / sqrt(pi)
    x.star <- dnorm.sd * (sqrt(2) * XW$x) + dnorm.mean
    out <- sum(func(x.star, ...) * w.star)
  } else {
    # Naylor & Smith (1982, 1988)
    if (iterative) {
      mu.est <- 0
      sd.est <- 1

      for (i in 1:max.iter) {
        w.star <- sqrt(2) * sd.est * dnorm(sqrt(2) * sd.est * XW$x + mu.est, dnorm.mean, dnorm.sd) * exp(XW$x^2) * XW$w
        x.star <- sqrt(2) * sd.est * XW$x + mu.est
        LIK <- sum(func(x.star, ...) * w.star)

        # update mu
        mu.est <- sum(x.star * (func(x.star, ...) * w.star) / LIK)

        # update sd
        var.est <- sum(x.star^2 * (func(x.star, ...) * w.star) / LIK) - mu.est^2
        sd.est <- sqrt(var.est)

        if (lav_verbose()) {
          cat(
            "i = ", i, "LIK = ", LIK, "mu.est = ", mu.est,
            "sd.est = ", sd.est, "\n"
          )
        }
      }
      out <- LIK

      # Liu and Pierce (1994)
    } else {
      # integrand g(x) = func(x) * dnorm(x; m, s^2)
      log.g <- function(x, ...) {
        ## FIXME: should we take the log right away?
        log(func(x, ...) * dnorm(x, mean = dnorm.mean, sd = dnorm.sd))
      }
      # find mu hat and sd hat
      mu.est <- optimize(
        f = log.g, interval = c(-10, 10),
        maximum = TRUE, tol = .Machine$double.eps, ...
      )$maximum
      H <- as.numeric(numDeriv::hessian(func = log.g, x = mu.est, ...))
      sd.est <- sqrt(1 / -H)

      w.star <- sqrt(2) * sd.est * dnorm(sd.est * (sqrt(2) * XW$x) + mu.est, dnorm.mean, dnorm.sd) * exp(XW$x^2) * XW$w
      x.star <- sd.est * (sqrt(2) * XW$x) + mu.est

      out <- sum(func(x.star, ...) * w.star)
    }
  }

  out
}

# integrand g(z) has the form g(z) = f(sz+m) dnorm(z, 0, 1)
lav_integration_f_dnorm_z <- function(func = NULL, # often ly.prod
                                      f.mean = 0, # f mean
                                      f.sd = 1, # f sd
                                      XW = NULL, # GH points
                                      n = 21L, # number of nodes
                                      adaptive = FALSE, # adaptive?
                                      iterative = FALSE, # iterative?
                                      max.iter = 20L, # max iterations
                                      ...) { # optional args for 'f'

  # create GH rule
  if (is.null(XW)) {
    XW <- lav_integration_gauss_hermite_xw(n = n, revert = TRUE)
  }

  if (!adaptive) {
    w.star <- XW$w / sqrt(pi)
    x.star <- sqrt(2) * XW$x
    out <- sum(func(f.sd * x.star + f.mean, ...) * w.star)
  } else {
    # Naylor & Smith (1982, 1988)
    if (iterative) {
      mu.est <- 0
      sd.est <- 1

      for (i in 1:max.iter) {
        w.star <- sqrt(2) * sd.est * dnorm(sd.est * sqrt(2) * XW$x + mu.est, 0, 1) * exp(XW$x^2) * XW$w
        x.star <- sd.est * (sqrt(2) * XW$x) + mu.est
        LIK <- sum(func(f.sd * x.star + f.mean, ...) * w.star)

        # update mu
        mu.est <- sum(x.star * (func(f.sd * x.star + f.mean, ...) * w.star) / LIK)

        # update sd
        var.est <- sum(x.star^2 * (func(f.sd * x.star + f.mean, ...) * w.star) / LIK) - mu.est^2
        sd.est <- sqrt(var.est)

        if (lav_verbose()) {
          cat(
            "i = ", i, "LIK = ", LIK, "mu.est = ", mu.est,
            "sd.est = ", sd.est, "\n"
          )
        }
      }
      out <- LIK

      # Liu and Pierce (1994)
    } else {
      # integrand g(x) = func(x) * dnorm(x; m, s^2)
      log.gz <- function(x, ...) {
        ## FIXME: should we take the log right away?
        log(func(f.sd * x + f.mean, ...) * dnorm(x, mean = 0, sd = 1))
      }
      # find mu hat and sd hat
      mu.est <- optimize(
        f = log.gz, interval = c(-10, 10),
        maximum = TRUE, tol = .Machine$double.eps, ...
      )$maximum
      H <- as.numeric(numDeriv::hessian(func = log.gz, x = mu.est, ...))
      sd.est <- sqrt(1 / -H)

      w.star <- sqrt(2) * sd.est * dnorm(sd.est * (sqrt(2) * XW$x) + mu.est, 0, 1) * exp(XW$x^2) * XW$w
      x.star <- sd.est * (sqrt(2) * XW$x) + mu.est

      out <- sum(func(f.sd * x.star + f.mean, ...) * w.star)
    }
  }

  out
}

# the univariate (weighted) linear model

# - scores/gradient/hessian
# - including the residual variance!

# YR - 30 Dec 2019 (replacing the old lav_ols.R routines)

lav_uvreg_fit <- function(y = NULL,
                          X = NULL,
                          wt = NULL,
                          optim.method = "nlminb",
                          control = list(),
                          output = "list") {
  # check weights
  if (is.null(wt)) {
    wt <- rep(1, length(y))
  } else {
    if (length(y) != length(wt)) {
      lav_msg_stop(gettext("length y is not the same as length wt"))
    }
    if (any(wt < 0)) {
      lav_msg_stop(gettext("all weights should be positive"))
    }
  }

  # optim.method
  minObjective <- lav_uvreg_min_objective
  minGradient <- lav_uvreg_min_gradient
  minHessian <- lav_uvreg_min_hessian
  if (optim.method == "nlminb" || optim.method == "nlminb2") {
    # nothing to do
  } else if (optim.method == "nlminb0") {
    minGradient <- minHessian <- NULL
  } else if (optim.method == "nlminb1") {
    minHessian <- NULL
  }

  # create cache environment
  cache <- lav_uvreg_init_cache(y = y, X = X, wt = wt)

  # optimize -- only changes from defaults
  control.nlminb <- list(
    eval.max = 20000L, iter.max = 10000L,
    trace = 0L, abs.tol = (.Machine$double.eps * 10)
  )
  control.nlminb <- modifyList(control.nlminb, control)

  optim <- nlminb(
    start = cache$theta, objective = minObjective,
    gradient = minGradient, hessian = minHessian,
    control = control.nlminb, cache = cache
  )

  if (output == "cache") {
    return(cache)
  }

  # return results as a list (to be compatible with lav_polychor.R)
  out <- list(
    theta = optim$par,
    nexo = cache$nexo,
    int.idx = cache$int.idx,
    slope.idx = cache$slope.idx,
    beta.idx = cache$beta.idx,
    var.idx = cache$var.idx,
    y = cache$y,
    wt = cache$wt,
    X = cache$X1[, -1L, drop = FALSE],
    yhat = cache$yhat
  )
}

# prepare cache environment
lav_uvreg_init_cache <- function(y = NULL,
                                 X = NULL,
                                 wt = rep(1, length(y)),
                                 parent = parent.frame()) {
  # y
  y <- as.vector(y)

  # X
  if (is.null(X)) {
    nexo <- 0L
    X1 <- matrix(1, length(y), 1)
  } else {
    X <- unname(X)
    nexo <- ncol(X)
    X1 <- cbind(1, X, deparse.level = 0)

    # new in 0.6-17: check if X is full rank
    if (!anyNA(X)) {
      if (qr(X)$rank < ncol(X)) {
        lav_msg_stop(gettext("matrix of exogenous covariates is rank deficient!
                    (i.e., some x variables contain redundant information)"))
      }
    }
  }

  # nobs
  if (is.null(wt)) {
    N <- length(y)
  } else {
    N <- sum(wt)
  }


  # indices of free parameters
  int.idx <- 1L
  slope.idx <- seq_len(nexo) + 1L
  beta.idx <- c(int.idx, slope.idx)
  var.idx <- 1L + nexo + 1L

  # starting values + crossprod
  if (any(is.na(y)) || any(is.na(X1))) {
    missing.idx <- which(apply(cbind(y, X1), 1, function(x) any(is.na(x))))
    y.tmp <- y[-missing.idx]
    X1.tmp <- X1[-missing.idx, , drop = FALSE]
    wt.tmp <- wt[-missing.idx]
    fit.lm <- stats::lm.wfit(y = y.tmp, x = X1.tmp, w = wt.tmp)
    theta.evar <- sum(fit.lm$residuals * wt.tmp * fit.lm$residuals) / sum(wt.tmp)

    lav_crossprod <- lav_matrix_crossprod
  } else {
    fit.lm <- stats::lm.wfit(y = y, x = X1, w = wt)
    theta.evar <- sum(fit.lm$residuals * wt * fit.lm$residuals) / sum(wt)

    lav_crossprod <- base::crossprod
  }
  theta.beta <- unname(fit.lm$coefficients)
  theta <- c(theta.beta, theta.evar)

  out <- list2env(
    list(
      y = y, X1 = X1, wt = wt, N = N,
      int.idx = int.idx, beta.idx = beta.idx,
      var.idx = var.idx, slope.idx = slope.idx, nexo = nexo,
      lav_crossprod = lav_crossprod,
      theta = theta
    ),
    parent = parent
  )

  out
}

# compute total (log)likelihood
lav_uvreg_loglik <- function(y = NULL,
                             X = NULL,
                             wt = rep(1, length(y)),
                             cache = NULL) {
  if (is.null(cache)) {
    cache <- lav_uvreg_fit(y = y, X = X, wt = wt, output = "cache")
  }
  lav_uvreg_loglik_cache(cache = cache)
}

lav_uvreg_loglik_cache <- function(cache = NULL) {
  with(cache, {
    # free parameters
    beta <- theta[beta.idx]
    evar <- theta[var.idx]

    yhat <- drop(X1 %*% beta)
    logliki <- dnorm(y, mean = yhat, sd = sqrt(evar), log = TRUE)

    # total weighted log-likelihood
    loglik <- sum(wt * logliki, na.rm = TRUE)

    return(loglik)
  })
}

# casewise scores
lav_uvreg_scores <- function(y = NULL,
                             X = NULL,
                             wt = rep(1, length(y)),
                             cache = NULL) {
  if (is.null(cache)) {
    cache <- lav_uvreg_fit(y = y, X = X, wt = wt, output = "cache")
  }
  lav_uvreg_scores_cache(cache = cache)
}

lav_uvreg_scores_cache <- function(cache = NULL) {
  with(cache, {
    res <- y - yhat
    resw <- res * wt
    evar2 <- evar * evar

    scores.beta <- 1 / evar * X1 * resw
    scores.evar <- -wt / (2 * evar) + 1 / (2 * evar2) * res * resw

    return(cbind(scores.beta, scores.evar, deparse.level = 0))
  })
}

# gradient
lav_uvreg_gradient <- function(y = NULL,
                               X = NULL,
                               wt = rep(1, length(y)),
                               cache = NULL) {
  if (is.null(cache)) {
    cache <- lav_uvreg_fit(y = y, X = X, wt = wt, output = "cache")
  }
  lav_uvreg_gradient_cache(cache = cache)
}

lav_uvreg_gradient_cache <- function(cache = NULL) {
  with(cache, {
    res <- y - yhat
    resw <- res * wt
    evar2 <- evar * evar

    dx.beta <- colSums(1 / evar * X1 * resw, na.rm = TRUE)
    dx.var <- sum(-wt / (2 * evar) + 1 / (2 * evar2) * res * resw, na.rm = TRUE)

    return(c(dx.beta, dx.var))
  })
}

# compute total Hessian
lav_uvreg_hessian <- function(y = NULL,
                              X = NULL,
                              wt = rep(1, length(y)),
                              cache = NULL) {
  if (is.null(cache)) {
    cache <- lav_uvreg_fit(y = y, X = X, wt = wt, output = "cache")
  }
  lav_uvreg_hessian_cache(cache = cache)
}

lav_uvreg_hessian_cache <- function(cache = NULL) {
  with(cache, {
    dx2.beta <- -1 / evar * lav_crossprod(X1 * wt, X1)
    dx.beta.var <- -1 / (evar2) * lav_crossprod(X1, resw)

    sq.evar <- sqrt(evar)
    sq.evar6 <- sq.evar * sq.evar * sq.evar * sq.evar * sq.evar * sq.evar
    dx2.var <- (sum(wt, na.rm = TRUE) / (2 * evar2) -
      1 / sq.evar6 * sum(resw * res, na.rm = TRUE))

    Hessian <- rbind(cbind(dx2.beta, dx.beta.var, deparse.level = 0),
      cbind(t(dx.beta.var), dx2.var, deparse.level = 0),
      deparse.level = 0
    )
    return(Hessian)
  })
}

# compute total (log)likelihood, for specific 'x' (nlminb)
lav_uvreg_min_objective <- function(x, cache = NULL) {
  cache$theta <- x
  -1 * lav_uvreg_loglik_cache(cache = cache) / cache$N
}

# compute gradient, for specific 'x' (nlminb)
lav_uvreg_min_gradient <- function(x, cache = NULL) {
  # check if x has changed
  if (!all(x == cache$theta)) {
    cache$theta <- x
    tmp <- lav_uvreg_loglik_cache(cache = cache)
  }
  -1 * lav_uvreg_gradient_cache(cache = cache) / cache$N
}

# compute hessian, for specific 'x' (nlminb)
lav_uvreg_min_hessian <- function(x, cache = NULL) {
  # check if x has changed
  if (!all(x == cache$theta)) {
    cache$theta <- x
    tmp <- lav_uvreg_loglik_cache(cache = cache)
    tmp <- lav_uvreg_gradient_cache(cache = cache)
  }
  -1 * lav_uvreg_hessian_cache(cache = cache) / cache$N
}

# update fit object with new parameters
lav_uvreg_update_fit <- function(fit.y = NULL,
                                 evar.new = NULL, beta.new = NULL) {
  if (is.null(evar.new) && is.null(beta.new)) {
    return(fit.y)
  }

  if (!is.null(evar.new)) {
    fit.y$theta[fit.y$var.idx] <- evar.new
  }
  if (!is.null(beta.new)) {
    fit.y$theta[fit.y$beta.idx] <- beta.new
  }

  beta <- fit.y$theta[fit.y$beta.idx]
  X <- fit.y$X
  X1 <- cbind(1, X, deparse.level = 0)

  fit.y$yhat <- drop(X1 %*% beta)

  fit.y
}

# EFA: exploratory factor analysis
#
# EFA is implemented as a special version of ESEM
# - it is therefore a wrapper around the lavaan() function to simplify
#   the input
# - a lavaan model is generated with a single 'block' that can be rotated
# - the 'default' output produces output that is more in line with traditional
#   EFA software (in R) like factanal() and fa() from the psych package

# YR 20 Sept 2022 - first version

efa <- function(data = NULL,
                nfactors = 1L,
                sample.cov = NULL,
                sample.nobs = NULL,
                rotation = "geomin",
                rotation.args = list(),
                ov.names = NULL,
                bounds = "pos.var",
                ...,
                output = "efa") {
  # rotation.args deprecation handling
  if (!missing(rotation.args)) {
    lav_deprecated_args("rotation", "rotation.args")
  }
  if (is.list(rotation)) {
    rotation.args <- modifyList(list(), rotation)
    rotation <- rotation[[1L]]
  }

  # handle dotdotdot
  dotdotdot <- list(...)

  # twolevel?
  twolevel.flag <- !is.null(dotdotdot$cluster)

  # sampling weights?
  sampling.weights.flag <- !is.null(dotdotdot$sampling.weights)

  # check for unallowed arguments
  if (!is.null(dotdotdot$group)) {
    lav_msg_stop(gettext("efa has no support for multiple groups (for now);
                          consider using the cfa() function in combination
                          with the efa() modifier."))
  }
  #if (!is.null(dotdotdot$sampling.weights)) {
  #  lav_msg_stop(gettext("efa has no support for sampling weights (for now);
  #                        consider using the cfa() function in combination
  #                        with the efa() modifier."))
  #}

  # if data= argument is used, convert to data.frame (eg matrix, tibble, ...)
  if (!is.null(data) && !inherits(data, "lavMoments")) {
    data <- as.data.frame(data)
  }

  # handle ov.names
  if (!is.null(data) && inherits(data, "lavMoments")) {
    if ("sample.cov" %in% names(data)) {
      ov.names <- rownames(data$sample.cov)
      if (is.null(ov.names)) {
        ov.names <- colnames(data$sample.cov)
      }
    } else {
      lav_msg_stop(gettext(
        "When data= is of class lavMoments, it must contain sample.cov"))
    }

  } else if (!is.null(data) && inherits(data, "data.frame")) {
    if (length(ov.names) > 0L) {
      NAMES <- ov.names
      if (twolevel.flag) {
        NAMES <- c(NAMES, dotdotdot$cluster)
      }
      if (sampling.weights.flag) {
        NAMES <- c(NAMES, dotdotdot$sampling.weights)
      }
      data <- data[, NAMES, drop = FALSE]
    } else {
      ov.names <- names(data)
      if (twolevel.flag) {
        ov.names <- ov.names[-which(ov.names == dotdotdot$cluster)]
      }
      if( sampling.weights.flag) {
        ov.names <- ov.names[-which(ov.names == dotdotdot$sampling.weights)]
      }
    }
  } else if (!is.null(sample.cov)) {
    ov.names <- rownames(sample.cov)
    if (is.null(ov.names)) {
      ov.names <- colnames(sample.cov)
    }
  }
  # ov.names?
  if (length(ov.names) == 0L) {
    lav_msg_stop(gettext(
      "could not extract variable names from data or sample.cov"))
  }

  # check nfactors
  if (any(nfactors < 1L)) {
    lav_msg_stop(gettext("nfactors must be greater than zero."))
  } else {
    # check for maximum number of factors
    # Fixme: can we do this more efficiently? also holds for categorical?
    nvar <- length(ov.names)
    p.star <- nvar * (nvar + 1) / 2
    nfac.max <- 0L
    for (nfac in seq_len(nvar)) {
      # compute number of free parameters
      npar <- nfac * nvar + nfac * (nfac + 1L) / 2 + nvar - nfac^2
      if (npar > p.star) {
        nfac.max <- nfac - 1L
        break
      }
    }
    if (any(nfactors > nfac.max)) {
      lav_msg_stop(gettextf("when nvar = %1$s the maximum number of factors
                            is %2$s", nvar, nfac.max))
    }
  }

  # output
  output <- tolower(output)
  if (!output %in% c("lavaan", "efa")) {
    lav_msg_stop(gettext("output= must be either \"lavaan\" or \"efa\""))
  }
  if (output == "lavaan" && length(nfactors) > 1L) {
    lav_msg_stop(gettext("when output = \"lavaan\", nfactors must be a
                         single (integer) number."))
  }

  # fit models
  nfits <- length(nfactors)
  out <- vector("list", length = nfits)
  for (f in seq_len(nfits)) {
    # generate model syntax
    model.syntax <- lav_syntax_efa(
      ov.names = ov.names,
      nfactors = nfactors[f],
      twolevel = twolevel.flag
    )
    # call lavaan (using sem())
    FIT <- do.call("sem",
      args = c(
        list(
          model = model.syntax,
          data = data,
          sample.cov = sample.cov,
          sample.nobs = sample.nobs,
          rotation = rotation,
          rotation.args = rotation.args,
          bounds = bounds
        ),
        dotdotdot
      )
    )

    if (output == "efa") {
      FIT@Options$model.type <- "efa"
    }

    out[[f]] <- FIT
  }

  # class
  if (nfits == 1L && output == "lavaan") {
    out <- out[[1]]
  } else {
    names(out) <- paste0("nf", nfactors)
    # add loadings element to the end of the list
    # so we an use the non-generic but useful loadings() function
    # from the stats package
    out$loadings <- lav_efa_get_loadings(out)
    class(out) <- c("efaList", "list")
  }

  out
}

# for blavaan
# TDJ: add "..." to make the generic actually generic, for lavaan.mi objects

# S3 generic for S3 dispatch
fitMeasures <- function(object, fit.measures = "all",
                        baseline.model = NULL, h1.model = NULL,
                        fm.args = list(
                          standard.test = "default",
                          scaled.test = "default",
                          rmsea.ci.level = 0.90,
                          rmsea.close.h0 = 0.05,
                          rmsea.notclose.h0 = 0.08,
                          robust = TRUE,
                          cat.check.pd = TRUE
                        ),
                        output = "vector", ...) {
  UseMethod("fitMeasures", object)
}
fitmeasures <- function(object, fit.measures = "all",
                        baseline.model = NULL, h1.model = NULL,
                        fm.args = list(
                          standard.test = "default",
                          scaled.test = "default",
                          rmsea.ci.level = 0.90,
                          rmsea.close.h0 = 0.05,
                          rmsea.notclose.h0 = 0.08,
                          robust = TRUE,
                          cat.check.pd = TRUE
                        ),
                        output = "vector", ...) {
  UseMethod("fitmeasures", object)
}


# S4 generic for S4 dispatch
setGeneric(
  "fitMeasures",
  function(object, fit.measures = "all",
           baseline.model = NULL, h1.model = NULL,
           fm.args = list(
             standard.test = "default",
             scaled.test = "default",
             rmsea.ci.level = 0.90,
             rmsea.close.h0 = 0.05,
             rmsea.notclose.h0 = 0.08,
             robust = TRUE,
             cat.check.pd = TRUE
           ),
           output = "vector", ...) {
    standardGeneric("fitMeasures")
  }
)
setGeneric(
  "fitmeasures",
  function(object, fit.measures = "all",
           baseline.model = NULL, h1.model = NULL,
           fm.args = list(
             standard.test = "default",
             scaled.test = "default",
             rmsea.ci.level = 0.90,
             rmsea.close.h0 = 0.05,
             rmsea.notclose.h0 = 0.08,
             robust = TRUE,
             cat.check.pd = TRUE
           ),
           output = "vector", ...) {
    standardGeneric("fitmeasures")
  }
)


# S3 generics
lavInspect <- function(object, what = "free",
                       add.labels = TRUE,
                       add.class = TRUE,
                       list.by.group = TRUE,
                       drop.list.single.group = TRUE) {
  UseMethod("lavInspect", object)
}

inspect <- function(object, what = "free", ...) {
    UseMethod("inspect", object)
}

lavTech <- function(object, what = "free",
                    add.labels = FALSE,
                    add.class = FALSE,
                    list.by.group = FALSE,
                    drop.list.single.group = FALSE) {
  UseMethod("lavTech", object)
}

# print only (standardized) loadings
lav_efa_print <- function(x, nd = 3L, cutoff = 0.3,
                             dot.cutoff = 0.1, alpha.level = 0.01, ...) {
  # unclass
  y <- unclass(x)

  if (!y$header$optim.converged) {
    cat("** WARNING ** Optimizer did not end normally\n")
    cat("** WARNING ** Estimates below are most likely unreliable\n")
  }

  # loadings per block
  for (b in seq_len(y$efa$nblocks)) {
    cat("\n")
    if (length(y$efa$block.label) > 0L) {
      cat(y$efa$block.label[[b]], ":\n\n", sep = "")
    }
    LAMBDA <- unclass(y$efa$lambda[[b]])
    lav_print_loadings(LAMBDA,
      nd = nd, cutoff = cutoff,
      dot.cutoff = dot.cutoff,
      alpha.level = alpha.level,
      x.se = y$efa$lambda.se[[b]]
    )
    cat("\n")
  }

  invisible(LAMBDA)
}

# print efaList
lav_efalist_print <- function(x, nd = 3L, cutoff = 0.3,
                          dot.cutoff = 0.1, alpha.level = 0.01, ...) {
  # unclass
  y <- unclass(x)

  # kill loadings element if present
  y[["loadings"]] <- NULL

  nfits <- length(y)
  RES <- vector("list", nfits)
  for (ff in seq_len(nfits)) {
    res <- lav_object_summary(y[[ff]],
      fit.measures = FALSE,
      estimates = FALSE,
      modindices = FALSE,
      efa = TRUE,
      efa.args = list(
        lambda           = TRUE,
        theta            = FALSE,
        psi              = FALSE,
        eigenvalues      = FALSE,
        sumsq.table      = FALSE,
        lambda.structure = FALSE,
        fs.determinacy   = FALSE,
        se               = FALSE,
        zstat            = FALSE,
        pvalue           = FALSE
      )
    )
    RES[[ff]] <- lav_efa_print(res,
      nd = nd, cutoff = cutoff,
      dot.cutoff = dot.cutoff,
      alpha.level = alpha.level, ...
    )
  }

  invisible(RES)
}


# print summary efaList
lav_efalist_summary_print <- function(x, nd = 3L, cutoff = 0.3,
                                  dot.cutoff = 0.1, alpha.level = 0.01,
                                  ...) {
  # unclass
  y <- unclass(x)

  # get nd, if it is stored as an attribute
  ND <- attr(y, "nd")
  if (!is.null(ND) && is.numeric(ND)) {
    nd <- as.integer(ND)
  }
  # get cutoff, if it is stored as an attribute
  CT <- attr(y, "cutoff")
  if (!is.null(CT) && is.numeric(CT)) {
    cutoff <- CT
  }
  # get dot.cutoff, if it is stored as an attribute
  DC <- attr(y, "dot.cutoff")
  if (!is.null(DC) && is.numeric(DC)) {
    dot.cutoff <- DC
  }
  # get alpha.level, if it is stored as an attribute
  AL <- attr(y, "alpha.level")
  if (!is.null(AL) && is.numeric(AL)) {
    alpha.level <- AL
  }

  cat("This is ",
    sprintf("lavaan %s", x$lavaan.version),
    " -- running exploratory factor analysis\n",
    sep = ""
  )

  # everything converged?
  if (!x$converged.flag) {
    cat("lavaan WARNING: not all models did converge!\n")
  }
  cat("\n")


  # estimator
  c1 <- c("Estimator")
  # second column
  tmp.est <- toupper(x$estimator)
  if (tmp.est == "DLS") {
    dls.first.letter <- substr(
      x$estimator.args$dls.GammaNT,
      1L, 1L
    )
    tmp.est <- paste("DLS-", toupper(dls.first.letter), sep = "")
  }
  c2 <- tmp.est

  # additional estimator args
  if (!is.null(x$estimator.args) &&
    length(x$estimator.args) > 0L) {
    if (x$estimator == "DLS") {
      c1 <- c(c1, "Estimator DLS value for a")
      c2 <- c(c2, x$estimator.args$dls.a)
    }
  }

  # rotation method
  c1 <- c(c1, "Rotation method")
  if (x$rotation == "none") {
    MM <- toupper(x$rotation)
  } else if (x$rotation.args$orthogonal) {
    MM <- paste(toupper(x$rotation), " ", "ORTHOGONAL",
      sep = ""
    )
  } else {
    MM <- paste(toupper(x$rotation), " ", "OBLIQUE",
      sep = ""
    )
  }
  c2 <- c(c2, MM)

  if (x$rotation != "none") {
    # method options
    if (x$rotation == "geomin") {
      c1 <- c(c1, "Geomin epsilon")
      c2 <- c(c2, x$rotation.args$geomin.epsilon)
    } else if (x$rotation == "orthomax") {
      c1 <- c(c1, "Orthomax gamma")
      c2 <- c(c2, x$rotation.args$orthomax.gamma)
    } else if (x$rotation == "cf") {
      c1 <- c(c1, "Crawford-Ferguson gamma")
      c2 <- c(c2, x$rotation.args$cf.gamma)
    } else if (x$rotation == "oblimin") {
      c1 <- c(c1, "Oblimin gamma")
      c2 <- c(c2, x$rotation.args$oblimin.gamma)
    } else if (x$rotation == "promax") {
      c1 <- c(c1, "Promax kappa")
      c2 <- c(c2, x$rotation.args$promax.kappa)
    }

    # rotation algorithm
    c1 <- c(c1, "Rotation algorithm (rstarts)")
    tmp <- paste(toupper(x$rotation.args$algorithm),
      " (", x$rotation.args$rstarts, ")",
      sep = ""
    )
    c2 <- c(c2, tmp)

    # Standardized metric (or not)
    c1 <- c(c1, "Standardized metric")
    if (x$rotation.args$std.ov) {
      c2 <- c(c2, "TRUE")
    } else {
      c2 <- c(c2, "FALSE")
    }

    # Row weights
    c1 <- c(c1, "Row weights")
    tmp.txt <- x$rotation.args$row.weights
    c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
      substring(tmp.txt, 2),
      sep = ""
    ))
  }

  # format c1/c2
  c1 <- format(c1, width = 33L)
  c2 <- format(c2,
    width = 18L + max(0, (nd - 3L)) * 4L,
    justify = "right"
  )

  # create character matrix
  M <- cbind(c1, c2, deparse.level = 0)
  colnames(M) <- rep("", ncol(M))
  rownames(M) <- rep(" ", nrow(M))

  # print
  write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)

  # data
  if (!is.null(x$lavdata)) {
    cat("\n")
    lav_data_print_short(x$lavdata, nd = nd)
  }

  # number of models
  nfits <- length(x$model.list)

  # number of factors
  nfactors <- x$nfactors

  # fit measures
  if (!is.null(x$fit.table)) {
    cat("\n")
    if (nfits > 1L) {
      cat("Overview models:\n")
    } else {
      cat("Fit measures:\n")
    }
    print(x$fit.table, nd = nd, shift = 2L)
  }

  # eigenvalues
  if (!is.null(x$model.list[[1]]$efa$eigvals[[1]])) {
    cat("\n")
    if (x$model.list[[1]]$efa$std.ov) {
      cat("Eigenvalues correlation matrix:\n")
    } else {
      cat("Eigenvalues covariance matrix:\n")
    }
    for (b in seq_len(x$model.list[[1]]$efa$nblocks)) {
      cat("\n")
      if (length(x$model.list[[1]]$efa$block.label) > 0L) {
        cat(x$model.list[[1]]$efa$block.label[[b]], ":\n\n", sep = "")
      }
      print(x$model.list[[1]]$efa$eigvals[[b]], nd = nd, shift = 2L)
    } # blocks
  }

  # print summary for each model
  for (f in seq_len(nfits)) {
    res <- x$model.list[[f]]
    attr(res, "nd") <- nd
    attr(res, "cutoff") <- cutoff
    attr(res, "dot.cutoff") <- dot.cutoff
    attr(res, "alpha.level") <- alpha.level

    if (nfits > 1L) {
      if (f == 1L) {
        cat("\n")
      }
      cat("Number of factors: ", nfactors[f], "\n")
    }
    # lav_summary_print() prints the $efa element (only) or res
    print(res)
  }

  invisible(y)
}

# the Multivariate normal distribution, unrestricted (h1), missing values

# 1) loglikelihood --> same as h0 but where Mu and Sigma are unrestricted
# 2) 3) 4) 5)      --> (idem)

# YR 26 Mar 2016: first version
# YR 20 Jan 2017: added _h1_omega_sw()

# here, we estimate Mu and Sigma from Y with missing values, assuming normality
# this is a rewrite of the 'estimate.moments.EM' function in <= 0.5-22
lav_mvnorm_missing_h1_estimate_moments <- function(Y = NULL,
                                                   Mp = NULL,
                                                   Yp = NULL,
                                                   wt = NULL,
                                                   Sinv.method = "eigen",
                                                   max.iter = 500L,
                                                   tol = 1e-05) {
  # check input
  Y <- as.matrix(Y)
  P <- NCOL(Y)
  if (!is.null(wt)) {
    N <- sum(wt)
  } else {
    N <- NROW(Y)
  }

  # missing patterns
  if (is.null(Mp)) {
    Mp <- lav_data_missing_patterns(Y)
  }
  if (is.null(Yp)) {
    Yp <- lav_samplestats_missing_patterns(Y = Y, Mp = Mp, wt = wt)
  }

  # covariances with zero coverage (perhaps planned?)
  zero.coverage.flag <- FALSE
  zero.coverage.idx <- which(Mp$coverage == 0) # as a vector
  if (length(zero.coverage.idx) > 0L) {
    zero.coverage.flag <- TRUE
    # this is a problem; the current implementation of the E-step does not
    # take this into account; for now, we need to switch to nlminb() instead
    lav_msg_warn(
      gettext("some covariances have zero coverage; the current implementation
               of the EM algorithm will ignore this!"))
  }

  if (is.null(max.iter)) {
    max.iter <- 500L
  }
  if (is.null(tol)) {
    tol <- 1e-05
  }

  # remove empty cases
  N.full <- N
  if (length(Mp$empty.idx) > 0L) {
    if (!is.null(wt)) {
      N <- N - sum(wt[Mp$empty.idx])
    } else {
      N <- N - length(Mp$empty.idx)
    }
  }

  # verbose?
  if (lav_verbose()) {
    cat("\n")
    cat("lav_mvnorm_missing_h1_estimate_moments: start EM steps\n")
  }

  # starting values; zero covariances to guarantee a pd matrix
  if (!is.null(wt)) {
    tmp <- na.omit(cbind(wt, Y))
    if (nrow(tmp) > 2L) {
      Y.tmp <- tmp[, -1, drop = FALSE]
      wt.tmp <- tmp[, 1]
      out <- stats::cov.wt(Y.tmp, wt = wt.tmp, method = "ML")
      Mu0 <- out$center
      var0 <- diag(out$cov)
    } else {
      Mu0 <- base::.colMeans(Y, m = N.full, n = P, na.rm = TRUE)
      Yc <- t(t(Y) - Mu0)
      var0 <- base::.colMeans(Yc * Yc, m = N.full, n = P, na.rm = TRUE)
    }
  } else {
    Mu0 <- base::.colMeans(Y, m = N.full, n = P, na.rm = TRUE)
    Yc <- t(t(Y) - Mu0)
    var0 <- base::.colMeans(Yc * Yc, m = N.full, n = P, na.rm = TRUE)
  }
  # sanity check
  bad.idx <- which(!is.finite(var0) | var0 == 0)
  if (length(bad.idx) > 0L) {
    var0[bad.idx] <- 1
  }
  bad.idx <- which(!is.finite(Mu0))
  if (length(bad.idx) > 0L) {
    Mu0[bad.idx] <- 0
  }
  Sigma0 <- diag(x = var0, nrow = P)
  Mu <- Mu0
  Sigma <- Sigma0

  # report
  if (lav_verbose()) {
    # fx0 <- lav_model_objective_fiml(Sigma.hat=Sigma, Mu.hat=Mu, M=Yp)
    fx0 <- lav_mvnorm_missing_loglik_samplestats(
      Yp = Yp,
      Mu = Mu, Sigma = Sigma,
      log2pi = FALSE,
      minus.two = TRUE
    ) / N
    cat(
      "  EM iteration:", sprintf("%4d", 0),
      " fx = ", sprintf("%15.10f", fx0),
      "\n"
    )
  }

  # EM steps
  for (i in 1:max.iter) {
    # E-step
    Estep <- lav_mvnorm_missing_estep(
      Y = Y, Mp = Mp, wt = wt,
      Mu = Mu, Sigma = Sigma,
      Sinv.method = Sinv.method
    )
    T1 <- Estep$T1
    T2 <- Estep$T2

    # M-step
    Mu <- T1 / N
    Sigma <- T2 / N - tcrossprod(Mu)

    # check if Sigma is near-pd (+ poor fix)
    ev <- eigen(Sigma, symmetric = TRUE, only.values = TRUE)
    evtol <- 1e-6 # FIXME!
    if (any(ev$values < evtol)) {
      # too.small <- which( ev$values < tol )
      # ev$values[too.small] <- tol
      # ev$values <- ev$values + tol
      # Sigma <- ev$vectors %*% diag(ev$values) %*% t(ev$vectors)

      # ridge
      diag(Sigma) <- diag(Sigma) + max(diag(Sigma)) * 1e-08
    }

    # max absolute difference in parameter values
    DELTA <- max(abs(c(Mu, lav_matrix_vech(Sigma)) -
      c(Mu0, lav_matrix_vech(Sigma0))))

    # report fx
    if (lav_verbose()) {
      # fx <- lav_model_objective_fiml(Sigma.hat=Sigma, Mu.hat=Mu, M=Yp)
      fx <- lav_mvnorm_missing_loglik_samplestats(
        Yp = Yp,
        Mu = Mu, Sigma = Sigma,
        log2pi = FALSE,
        minus.two = TRUE
      ) / N
      cat(
        "  EM iteration:", sprintf("%4d", i),
        " fx = ", sprintf("%15.10f", fx),
        " delta par = ", sprintf("%9.8f", DELTA),
        "\n"
      )
    }

    # convergence check: using parameter values:
    if (DELTA < tol) {
      break
    }

    # again
    Mu0 <- Mu
    Sigma0 <- Sigma
  } # EM iterations

  if (lav_verbose()) {
    cat("\nSigma:\n")
    print(Sigma)
    cat("\nMu:\n")
    print(Mu)
    cat("\n")
  }

  # compute fx if we haven't already
  if (!lav_verbose()) {
    # fx <- lav_model_objective_fiml(Sigma.hat = Sigma, Mu.hat = Mu, M = Yp)
    fx <- lav_mvnorm_missing_loglik_samplestats(
      Yp = Yp,
      Mu = Mu, Sigma = Sigma,
      log2pi = FALSE,
      minus.two = TRUE
    ) / N
  }

  # warning?
  if (i == max.iter) {
    lav_msg_warn(
      gettext("Maximum number of iterations reached when computing the sample
              moments using EM; use the em.h1.iter.max= argument to increase
              the number of iterations")
    )
  }

  ev <- eigen(Sigma, symmetric = TRUE, only.values = TRUE)$values
  if (any(ev < 1e-05)) { # make an option?
    lav_msg_warn(
      gettext("The smallest eigenvalue of the EM estimated variance-covariance
              matrix (Sigma) is smaller than 1e-05; this may cause numerical
              instabilities; interpret the results with caution.")
    )
  }

  list(Sigma = Sigma, Mu = Mu, fx = fx)
}

# if we cannot use the EM algorithm (zero coverage?), we can always use
# plain FIML and nlminb() instead
#
# single level only
lav_mvnorm_missing_h1_estimate_moments_chol <- function(lavdata = NULL,
                                                        lavsamplestats = NULL,
                                                        lavoptions = NULL,
                                                        group = 1L) {
  # not for multilevel
  stopifnot(lavdata@nlevels == 1L)

  # no ov.names.x in lavdata
  lavdata@ov.names.x <- vector("list", length = lavdata@ngroups)

  # construct unrestricted partable (using chol parameterization)
  # for this group only
  lavpartable <- lav_partable_unrestricted_chol(
                             lavdata = lavdata, lavoptions = lavoptions,
                             lavpta = NULL, group = group)

  lavoptions2 <- lavoptions
  lavoptions2$estimator <- "ML"
  lavoptions2$missing <- "ml"
  lavoptions2$se <- "none"
  lavoptions2$test <- "none"
  lavoptions2$do.fit <- TRUE
  lavoptions2$optim.method <- "nlminb"
  lavoptions2$h1 <- FALSE
  lavoptions2$implied <- TRUE
  lavoptions2$loglik <- TRUE
  lavoptions2$baseline <- FALSE
  lavoptions2$fixed.x <- FALSE # even if model uses fixed.x=TRUE
  lavoptions2$model.type <- "unrestricted"
  lavoptions2$optim.attempts <- 4L
  lavoptions2$check.gradient <- FALSE
  lavoptions2$optim.force.convergence <- TRUE # for now...
  lavoptions2$control <- list(rel.tol = 1e-7)
  lavoptions2$start <- "simple" # add this point, we have no lavh1 yet!
  FIT <- lavaan(lavpartable,
    slotOptions = lavoptions2,
    slotSampleStats = lavsamplestats,
    slotData = lavdata,
    warn = FALSE
  )

  out <- list(Sigma = FIT@implied$cov[[1]],
              Mu = FIT@implied$mean[[1]],
              fx = FIT@optim$fx)

  out
}

# compute N times ACOV(Mu, vech(Sigma))
# in the literature: - `Omega_{SW}'
#                    - `Gamma for incomplete data'
#                    - (N times the) sandwich estimator for acov(mu,vech(Sigma))
lav_mvnorm_missing_h1_omega_sw <- function(Y = NULL,
                                           Mp = NULL,
                                           wt = NULL,
                                           cluster.idx = NULL,
                                           Yp = NULL,
                                           Sinv.method = "eigen",
                                           Mu = NULL,
                                           Sigma = NULL,
                                           x.idx = integer(0L),
                                           Sigma.inv = NULL,
                                           information = "observed") {
  # missing patterns
  if (is.null(Mp)) {
    Mp <- lav_data_missing_patterns(Y)
  }

  # sample stats per pattern
  if (is.null(Yp) && (information == "observed" || is.null(Sigma))) {
    Yp <- lav_samplestats_missing_patterns(Y = Y, Mp = Mp, wt = wt)
  }

  # Sigma and Mu
  if (is.null(Sigma) || is.null(Mu)) {
    out <- lav_mvnorm_missing_h1_estimate_moments(Y = Y, Mp = Mp, Yp = Yp)
    Mu <- out$Mu
    Sigma <- out$Sigma
  }

  # information matrices
  info <- lav_mvnorm_missing_information_both(
    Y = Y, Mp = Mp, Mu = Mu,
    wt = wt, cluster.idx = cluster.idx,
    Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method,
    Sigma.inv = Sigma.inv, information = information
  )

  A <- info$Abeta
  A.inv <- lav_matrix_symmetric_inverse(
    S = A, logdet = FALSE,
    Sinv.method = Sinv.method
  )
  B <- info$Bbeta

  # sandwich
  SW <- A.inv %*% B %*% A.inv

  SW
}



# user visible function to add 'matrix' entries in the parameter table
lavMatrixRepresentation <- function(partable, representation = "LISREL",
                                    allow.composites = TRUE, # new in 0.6-20
                                    add.attributes = FALSE,
                                    as.data.frame. = TRUE) {
  # check parameter table
  partable <- lav_partable_complete(partable)

  # get model matrices
  if (representation == "LISREL") {
    REP <- lav_lisrel(partable, target = NULL, extra = add.attributes,
                      allow.composites = allow.composites)
  } else if (representation == "RAM") {
    REP <- lav_ram(partable, target = NULL, extra = add.attributes)
  } else {
    lav_msg_stop(gettext("representation must either \"LISREL\" or \"RAM\"."))
  }

  partable$mat <- REP$mat
  partable$row <- REP$row
  partable$col <- REP$col

  if (as.data.frame.) {
    partable <- as.data.frame(partable, stringsAsFactors = FALSE)
    class(partable) <- c("lavaan.data.frame", "data.frame")
  }

  if (add.attributes) {
    if (representation == "LISREL") {
      attr(partable, "ov.dummy.names.nox") <- attr(REP, "ov.dummy.names.nox")
      attr(partable, "ov.dummy.names.x") <- attr(REP, "ov.dummy.names.x")
    } else if (representation == "RAM") {
      attr(partable, "ov.idx") <- attr(REP, "ov.idx")
    }
    attr(partable, "mmNames") <- attr(REP, "mmNames")
    attr(partable, "mmNumber") <- attr(REP, "mmNumber")
    attr(partable, "mmRows") <- attr(REP, "mmRows")
    attr(partable, "mmCols") <- attr(REP, "mmCols")
    attr(partable, "mmDimNames") <- attr(REP, "mmDimNames")
    attr(partable, "mmSymmetric") <- attr(REP, "mmSymmetric")
  }

  partable
}

# functions to deal with binary/ordinal univariate data

# - probit regression
# - ordinal probit regression
# - logit regression
# - ordinal logit regression

# Note: the idea of using 'o1' and 'o2' when computing z1/z2 comes from
#       the dissertation of Christensen, 2012 (see also his `ordinal' package)

# YR - 25 Nov 2019 (replacing the old lav_probit.R routines)

lav_uvord_fit <- function(y = NULL,
                          X = NULL,
                          wt = rep(1, length(y)),
                          lower = -Inf,
                          upper = +Inf,
                          optim.method = "nlminb",
                          logistic = FALSE, # probit is the default
                          control = list(),
                          output = "list") {
  # y
  if (!is.integer(y)) {
    # brute force, no checking! (this is a lower-level function)
    y <- as.integer(y)
  }
  if (!min(y, na.rm = TRUE) == 1L) {
    y <- as.integer(ordered(y))
  }

  # check weights
  if (is.null(wt)) {
    wt <- rep(1, length(y))
  } else {
    if (length(y) != length(wt)) {
      lav_msg_stop(gettext("length y is not the same as length wt"))
    }
    if (any(wt < 0)) {
      lav_msg_stop(gettext("all weights should be positive"))
    }
  }

  # check lower/upper
  # TODO

  # optim.method
  minObjective <- lav_uvord_min_objective
  y.ncat <- length(tabulate(y)) # number of response categories
  if (y.ncat > 1L) {
    minGradient <- lav_uvord_min_gradient
    minHessian <- lav_uvord_min_hessian
  } else {
    minGradient <- NULL
    minHessian <- NULL
  }
  if (optim.method == "nlminb" || optim.method == "nlminb2") {
    # nothing to do
  } else if (optim.method == "nlminb0") {
    minGradient <- minHessian <- NULL
  } else if (optim.method == "nlminb1") {
    minHessian <- NULL
  }

  # create cache environment
  cache <- lav_uvord_init_cache(y = y, X = X, wt = wt, logistic = logistic)

  # optimize -- only changes from defaults
  control.nlminb <- list(
    eval.max = 20000L, iter.max = 10000L,
    trace = 0L, abs.tol = (.Machine$double.eps * 10)
  )
  control.nlminb <- modifyList(control.nlminb, control)

  optim <- nlminb(
    start = cache$theta, objective = minObjective,
    gradient = minGradient, hessian = minHessian,
    control = control.nlminb, lower = lower, upper = upper,
    cache = cache
  )

  if (output == "cache") {
    return(cache)
  }

  # return results as a list (to be compatible with lav_polychor.R)
  out <- list(
    theta = optim$par,
    nexo = cache$nexo,
    nth = cache$nth,
    th.idx = seq_len(cache$nth),
    slope.idx = seq_len(length(optim$par))[-seq_len(cache$nth)],
    missing.idx = cache$missing.idx,
    y = cache$y,
    wt = cache$wt,
    Y1 = cache$Y1,
    Y2 = cache$Y2,
    z1 = cache$z1,
    z2 = cache$z2,
    X = cache$X
  )
}

# shortcut to get (possibly weighted) thresholds only, if no eXo
lav_uvord_th <- function(y = NULL, wt = NULL) {
  y.freq <- tabulate(y) # unweighted
  y.ncat <- length(y.freq) # number of response categories
  if (is.null(wt)) {
    y.prop <- y.freq / sum(y.freq)
  } else {
    y.freq <- numeric(y.ncat) # numeric! weights...
    for (cat in seq_len(y.ncat)) {
      y.freq[cat] <- sum(wt[y == cat], na.rm = TRUE)
    }
    y.prop <- y.freq / sum(y.freq)
  }

  qnorm(cumsum(y.prop[-length(y.prop)]))
}


# prepare cache environment
lav_uvord_init_cache <- function(y = NULL,
                                 X = NULL,
                                 wt = rep(1, length(y)),
                                 logistic = FALSE,
                                 parent = parent.frame()) {
  nobs <- length(y)

  # number of response categories
  y.ncat <- length(tabulate(y)) # unweighted
  # number of thresholds
  nth <- y.ncat - 1L

  # X
  if (is.null(X)) {
    nexo <- 0L
  } else {
    X <- unname(X)
    nexo <- ncol(X)
    # new in 0.6-17: check if X is full rank
    if (!anyNA(X)) {
      if (qr(X)$rank < ncol(X)) {
        lav_msg_stop(gettext(
          "matrix of exogenous covariates is rank deficient!(i.e., some x
          variables contain redundant information)"))
      }
    }
  }

  # nobs
  if (is.null(wt)) {
    N <- nobs
  } else {
    N <- sum(wt)
  }

  # frequencies (possibly weighted by wt)
  y.freq <- numeric(y.ncat) # numeric! weights...
  for (cat in seq_len(y.ncat)) {
    y.freq[cat] <- sum(wt[y == cat], na.rm = TRUE)
  }
  y.prop <- y.freq / sum(y.freq)

  # missing values
  missing.idx <- which(is.na(y))

  # missing values
  if (any(is.na(y)) || (!is.null(X) && any(is.na(X)))) {
    lav_crossprod <- lav_matrix_crossprod
  } else {
    lav_crossprod <- base::crossprod
  }

  # distribution
  if (logistic) {
    pfun <- plogis
    dfun <- dlogis
    gfun <- function(x) {
      # FIXMe: is it worth making this work for abs(x) > 200?
      out <- numeric(length(x))
      out[is.na(x)] <- NA
      x.ok <- which(abs(x) < 200)
      e <- exp(-x[x.ok])
      e1 <- 1 + e
      e2 <- e1 * e1
      e4 <- e2 * e2
      out[x.ok] <- -e / e2 + e * (2 * (e * e1)) / e4
      out
    }
  } else {
    pfun <- pnorm
    dfun <- dnorm
    gfun <- function(x) {
      -x * dnorm(x)
    }
  }

  # offsets -Inf/+Inf
  o1 <- ifelse(y == nth + 1, 100, 0)
  o2 <- ifelse(y == 1, -100, 0)

  # TH matrices (Matrix logical?)
  if (nth > 0L) {
    Y1 <- matrix(1:nth, nobs, nth, byrow = TRUE) == y
    Y2 <- matrix(1:nth, nobs, nth, byrow = TRUE) == (y - 1L)
  } else {
    Y1 <- Y2 <- matrix(nrow = nobs, ncol = 0)
  }

  # starting values
  if (nexo == 0L && nth > 0L) {
    if (logistic) {
      th.start <- qlogis(cumsum(y.prop[-length(y.prop)]))
    } else {
      th.start <- qnorm(cumsum(y.prop[-length(y.prop)]))
    }
  } else if ((nth == 1L && nexo > 0L) || nth == 0L) {
    th.start <- 0
  } else {
    if (logistic) {
      # th.start <- seq(-1, 1, length = nth) / 2
      th.start <- qlogis((1:nth) / (nth + 1))
    } else {
      # th.start <- seq(-1, 1, length = nth) / 2
      th.start <- qnorm((1:nth) / (nth + 1))
    }
  }
  beta.start <- rep(0, nexo)
  theta <- c(th.start, beta.start)

  # parameter labels (for pretty output only)
  # th.lab <- paste("th", seq_len(nth), sep = "")
  # sl.lab <- character(0L)
  # if(nexo > 0L) {
  #    sl.lab <- paste("beta", seq_len(nexo), sep = "")
  # }
  # theta.labels <- c(th.lab, sl.lab)

  out <- list2env(
    list(
      y = y, X = X, wt = wt, o1 = o1, o2 = o2,
      missing.idx = missing.idx, N = N,
      pfun = pfun, dfun = dfun, gfun = gfun,
      lav_crossprod = lav_crossprod,
      nth = nth, nobs = nobs, y.ncat = y.ncat, nexo = nexo,
      Y1 = Y1, Y2 = Y2,
      theta = theta
    ),
    parent = parent
  )

  out
}

# compute total (log)likelihood
lav_uvord_loglik <- function(y = NULL,
                             X = NULL,
                             wt = rep(1, length(y)),
                             logistic = FALSE,
                             cache = NULL) {
  if (is.null(cache)) {
    cache <- lav_uvord_fit(
      y = y, X = X, wt = wt,
      logistic = logistic, output = "cache"
    )
  }
  lav_uvord_loglik_cache(cache = cache)
}

lav_uvord_loglik_cache <- function(cache = NULL) {
  with(cache, {
    # Note: we could treat the binary case separately,
    # avoiding calling pfun() twice

    # free parameters
    th <- theta[1:nth]
    TH <- c(0, th, 0)
    beta <- theta[-c(1:nth)]
    if (nexo > 0L) {
      eta <- drop(X %*% beta)
      z1 <- TH[y + 1L] - eta + o1
      z2 <- TH[y] - eta + o2
    } else {
      z1 <- TH[y + 1L] + o1
      z2 <- TH[y] + o2
    }
    pi.i <- pfun(z1) - pfun(z2)

    # avoid numerical degradation if z2 (and therefore z1) are both 'large'
    # and the pfuns are close to 1.0
    large.idx <- which(z2 > 1)
    if (length(large.idx) > 0L) {
      pi.i[large.idx] <- (pfun(z2[large.idx], lower.tail = FALSE) -
        pfun(z1[large.idx], lower.tail = FALSE))
    }

    loglik <- sum(wt * log(pi.i), na.rm = TRUE)

    return(loglik)
  })
}

# casewise scores
lav_uvord_scores <- function(y = NULL,
                             X = NULL,
                             wt = rep(1, length(y)),
                             use.weights = TRUE,
                             logistic = FALSE,
                             cache = NULL) {
  if (is.null(cache)) {
    cache <- lav_uvord_fit(
      y = y, X = X, wt = wt,
      logistic = logistic, output = "cache"
    )
  }
  SC <- lav_uvord_scores_cache(cache = cache)

  if (!is.null(wt) && use.weights) {
    SC <- SC * wt
  }

  SC
}

lav_uvord_scores_cache <- function(cache = NULL) {
  with(cache, {
    # d logl / d pi
    dldpi <- 1 / pi.i # unweighted!

    # we assume z1/z2 are available
    p1 <- dfun(z1)
    p2 <- dfun(z2)

    # th
    scores.th <- dldpi * (Y1 * p1 - Y2 * p2)

    # beta
    if (nexo > 0L) {
      scores.beta <- dldpi * (-X) * (p1 - p2)
      return(cbind(scores.th, scores.beta, deparse.level = 0))
    } else {
      return(scores.th)
    }
  })
}

lav_uvord_gradient_cache <- function(cache = NULL) {
  with(cache, {
    # d logl / d pi
    wtp <- wt / pi.i
    p1 <- dfun(z1)
    p2 <- dfun(z2)

    # th
    dxa <- Y1 * p1 - Y2 * p2
    scores.th <- wtp * dxa

    # beta
    if (nexo > 0L) {
      dxb <- X * (p1 - p2) # == X*p1 - X*p2
      scores.beta <- wtp * (-dxb)
      return(colSums(cbind(scores.th, scores.beta, deparse.level = 0),
        na.rm = TRUE
      ))
    } else {
      return(colSums(scores.th, na.rm = TRUE))
    }
  })
}


# compute total Hessian
lav_uvord_hessian <- function(y = NULL,
                              X = NULL,
                              wt = rep(1, length(y)),
                              logistic = FALSE,
                              cache = NULL) {
  if (is.null(cache)) {
    cache <- lav_uvord_fit(
      y = y, X = X, wt = wt,
      logistic = logistic, output = "cache"
    )
  }
  tmp <- lav_uvord_loglik_cache(cache = cache)
  tmp <- lav_uvord_gradient_cache(cache = cache)
  lav_uvord_hessian_cache(cache = cache)
}

lav_uvord_hessian_cache <- function(cache = NULL) {
  with(cache, {
    wtp2 <- wt / (pi.i * pi.i)

    g1w <- gfun(z1) * wtp
    g2w <- gfun(z2) * wtp

    Y1gw <- Y1 * g1w
    Y2gw <- Y2 * g2w

    dx2.tau <- (lav_crossprod(Y1gw, Y1) - lav_crossprod(Y2gw, Y2) -
      lav_crossprod(dxa, dxa * wtp2))

    if (nexo == 0L) {
      return(dx2.tau)
    }

    dxb2 <- dxb * wtp2
    dx2.beta <- (lav_crossprod(X * g1w, X) - lav_crossprod(X * g2w, X) -
      lav_crossprod(dxb, dxb2))

    dx.taubeta <- (-lav_crossprod(Y1gw, X) + lav_crossprod(Y2gw, X) +
      lav_crossprod(dxa, dxb2))

    Hessian <- rbind(cbind(dx2.tau, dx.taubeta, deparse.level = 0),
      cbind(t(dx.taubeta), dx2.beta, deparse.level = 0),
      deparse.level = 0
    )

    return(Hessian)
  })
}


# compute total (log)likelihood, for specific 'x' (nlminb)
lav_uvord_min_objective <- function(x, cache = NULL) {
  # check order of first 2 thresholds; if x[1] > x[2], return Inf
  # new in 0.6-8
  if (cache$nth > 1L && x[1] > x[2]) {
    return(+Inf)
  }
  if (cache$nth > 2L && x[2] > x[3]) {
    return(+Inf)
  }
  if (cache$nth > 3L && x[3] > x[4]) {
    return(+Inf)
  }
  cache$theta <- x
  -1 * lav_uvord_loglik_cache(cache = cache) / cache$N
}

# compute gradient, for specific 'x' (nlminb)
lav_uvord_min_gradient <- function(x, cache = NULL) {
  # check if x has changed
  if (!all(x == cache$theta)) {
    cache$theta <- x
    tmp <- lav_uvord_loglik_cache(cache = cache)
  }
  -1 * lav_uvord_gradient_cache(cache = cache) / cache$N
}

# compute hessian, for specific 'x' (nlminb)
lav_uvord_min_hessian <- function(x, cache = NULL) {
  # check if x has changed
  if (!all(x == cache$theta)) {
    cache$theta <- x
    tmp <- lav_uvord_loglik_cache(cache = cache)
    tmp <- lav_uvord_gradient_cache(cache = cache)
  }
  -1 * lav_uvord_hessian_cache(cache = cache) / cache$N
}

# get 'z1' and 'z2' values, given (new) values for the parameters
# only needed for lav_bvord_cor_scores(), which is called from
# lav_pml_dploglik_dimplied() in lav_model_gradient_pml.R
lav_uvord_update_fit <- function(fit.y = NULL, th.new = NULL, sl.new = NULL) {
  # return fit.y with 'update' z1/z2 values
  if (is.null(th.new) && is.null(sl.new)) {
    return(fit.y)
  }

  if (!is.null(th.new)) {
    fit.y$theta[fit.y$th.idx] <- th.new
  }
  if (!is.null(sl.new)) {
    fit.y$theta[fit.y$slope.idx] <- sl.new
  }

  nth <- length(fit.y$th.idx)
  o1 <- ifelse(fit.y$y == nth + 1, 100, 0)
  o2 <- ifelse(fit.y$y == 1, -100, 0)

  theta <- fit.y$theta
  th <- theta[1:nth]
  TH <- c(0, th, 0)
  beta <- theta[-c(1:nth)]
  y <- fit.y$y
  X <- fit.y$X
  if (length(fit.y$slope.idx) > 0L) {
    eta <- drop(X %*% beta)
    fit.y$z1 <- TH[y + 1L] - eta + o1
    fit.y$z2 <- TH[y] - eta + o2
  } else {
    fit.y$z1 <- TH[y + 1L] + o1
    fit.y$z2 <- TH[y] + o2
  }

  fit.y
}

# factor score regression

# four methods:
#  - naive (regression or Bartlett)
#  - Skrondal & Laake (2001) (regression models only)
#  - Croon (2002) (general + robust SE)
#  - simple: always use Bartlett, replace var(f) by psi estimate
#
# TODO:
#  - Hishino & Bentler: this is simple + WLS

# changes 09 dec 2018: add analytic SE ('standard')
#                      make this the new default

fsr <- function(model = NULL,
                data = NULL,
                cmd = "sem",
                fsr.method = "Croon",
                fs.method = "Bartlett",
                fs.scores = FALSE,
                mm.options = list(se = "standard", test = "standard"),
                Gamma.NT = TRUE,
                lvinfo = FALSE,
                mm.list = NULL,
                ...,
                output = "lavaan") {
  # we need full data
  if (is.null(data)) {
    lav_msg_stop(gettext("full data is required for factor score regression"))
  }
  # dot dot dot
  dotdotdot <- list(...)
  # ------------- handling of warn/debug/verbose switches ----------
  if (!is.null(dotdotdot$debug)) {
    current.debug <- lav_debug()
    if (lav_debug(dotdotdot$debug))
      on.exit(lav_debug(current.debug), TRUE)
    dotdotdot$debug <- NULL
    if (lav_debug()) {
      dotdotdot$warn <- TRUE       # force warnings if debug
      dotdotdot$verbose <- TRUE    # force verbose if debug
    }
  }
  if (!is.null(dotdotdot$warn)) {
    current.warn <- lav_warn()
    if (lav_warn(dotdotdot$warn))
      on.exit(lav_warn(current.warn), TRUE)
    dotdotdot$warn <- NULL
  }
  if (!is.null(dotdotdot$verbose)) {
    current.verbose <- lav_verbose()
    if (lav_verbose(dotdotdot$verbose))
      on.exit(lav_verbose(current.verbose), TRUE)
    dotdotdot$verbose <- NULL
  }

  # check fsr.method argument
  fsr.method <- tolower(fsr.method)
  if (fsr.method == "naive") {
    # nothing to do
  } else if (fsr.method %in% c(
    "skrondal", "laake", "skrondallaake",
    "skrondal.laake", "skrondal-laake"
  )) {
    fsr.method <- "skrondal.laake"
  } else if (fsr.method == "croon") {
    # nothing to do
  } else if (fsr.method == "simple") {
    # force fs.method to Bartlett!
    fs.method <- "Bartlett"
  } else {
    lav_msg_stop(gettext("invalid option for argument fsr.method:"),
      fsr.method)
  }

  # check fs.method argument
  fs.method <- tolower(fs.method)
  if (fs.method %in% c("bartlett", "barttlett", "bartlet")) {
    fs.method <- "Bartlett"
  } else if (fs.method == "regression") {
    # nothing to do
  } else {
    lav_msg_stop(gettext("invalid option for argument fs.method:"),
      fs.method
    )
  }

  if (output %in% c("scores", "fs.scores", "fsr.scores")) {
    fs.scores <- TRUE
  }

  # change 'default' values for fsr
  if (is.null(dotdotdot$se)) {
    dotdotdot$se <- "standard"
  }
  if (is.null(dotdotdot$test)) {
    dotdotdot$test <- "standard"
  }
  if (is.null(dotdotdot$missing)) {
    dotdotdot$missing <- "ml"
  }
  if (is.null(dotdotdot$meanstructure)) {
    dotdotdot$meanstructure <- TRUE
  }


  # STEP 0: process full model, without fitting
  dotdotdot0 <- dotdotdot
  dotdotdot0$do.fit <- NULL
  dotdotdot0$se <- "none" # to avoid warning about missing="listwise"
  dotdotdot0$test <- "none" # to avoid warning about missing="listwise"

  # check for arguments that we do not want (eg sample.cov)?
  # TODO

  # initial processing of the model, no fitting
  FIT <- suppressWarnings(do.call(cmd,
    args = c(list(
      model = model,
      data = data,
      # meanstructure = TRUE,
      do.fit = FALSE
    ), dotdotdot0)
  ))
  lavoptions <- lavInspect(FIT, "options")
  # restore
  lavoptions$se <- dotdotdot$se
  lavoptions$test <- dotdotdot$test
  ngroups <- lavInspect(FIT, "ngroups")
  lavpta <- FIT@pta
  lavpartable <- lav_partable_set_cache(FIT@ParTable, lavpta)

  # FIXME: not ready for multiple groups yet
  if (ngroups > 1L) {
    lav_msg_stop(gettext("fsr code not ready for multiple groups (yet)"))
  }

  # if missing = "listwise", make data complete
  if (lavoptions$missing == "listwise") {
    # FIXME: make this work for multiple groups!!
    OV <- unique(unlist(lavpta$vnames$ov))
    data <- na.omit(data[, OV])
  }

  # any `regular' latent variables?
  lv.names <- unique(unlist(FIT@pta$vnames$lv.regular))
  ov.names <- unique(unlist(FIT@pta$vnames$ov))

  # check for higher-order factors
  good.idx <- logical(length(lv.names))
  for (f in seq_len(length(lv.names))) {
    # check the indicators
    FAC <- lv.names[f]
    IND <- lavpartable$rhs[lavpartable$lhs == FAC &
      lavpartable$op == "=~"]
    if (all(IND %in% ov.names)) {
      good.idx[f] <- TRUE
    }
    # FIXME: check for mixed lv/ov indicators
  }
  lv.names <- lv.names[good.idx]

  if (length(lv.names) == 0L) {
    lav_msg_stop(gettext("model does not contain any (measured) latent variables"))
  }
  nfac <- length(lv.names)

  # check parameter table
  PT <- lav_partable_set_cache(parTable(FIT))
  PT$est <- PT$se <- NULL

  # extract structural part
  PT.PA <- lav_partable_subset_structural_model(PT)

  # check if we can use skrondal & laake (no mediational terms?)
  if (fsr.method == "skrondal.laake") {
    # determine eqs.y and eqs.x names
    eqs.x.names <- unlist(FIT@pta$vnames$eqs.x)
    eqs.y.names <- unlist(FIT@pta$vnames$eqs.y)
    eqs.names <- unique(c(eqs.x.names, eqs.y.names))
    if (any(eqs.x.names %in% eqs.y.names)) {
      lav_msg_stop(
        gettextf("mediational relationships are not allowed for the
                 Skrondal.Laake method; use %s instead.",
                 dQuote("Croon")))
    }
  }


  # STEP 1a: compute factor scores for each measurement model (block)

  # how many measurement models?
  if (!is.null(mm.list)) {
    if (fsr.method != "simple") {
      lav_msg_stop(gettext("mm.list only available if fsr.method = \"simple\""))
    }

    nblocks <- length(mm.list)
    # check each measurement block
    for (b in seq_len(nblocks)) {
      if (!all(mm.list[[b]] %in% lv.names)) {
        lav_msg_stop(
          gettextf("mm.list contains unknown latent variable(s): %s",
            lav_msg_view(mm.list[[b]][mm.list[[b]] %in% lv.names],
                         log.sep = "none")))
      }
    }
  } else {
    # TODO: here comes the automatic 'detection' of linked
    #       measurement models
    #
    # for now we take a single latent variable per measurement model block
    mm.list <- as.list(lv.names)
    nblocks <- length(mm.list)
  }

  # compute factor scores, per latent variable
  FS.SCORES <- vector("list", length = ngroups)
  LVINFO <- vector("list", length = ngroups)
  if (ngroups > 1L) {
    names(FS.SCORES) <- names(LVINFO) <- lavInspect(FIT, "group.label")
  }
  for (g in 1:ngroups) {
    FS.SCORES[[g]] <- vector("list", length = nblocks)
    # names(FS.SCORES[[g]]) <-  lv.names
    LVINFO[[g]] <- vector("list", length = nblocks)
    # names(LVINFO[[g]]) <- lv.names
  }

  # adjust options
  dotdotdot2 <- dotdotdot
  dotdotdot2$se <- "none"
  dotdotdot2$test <- "none"
  dotdotdot2$debug <- FALSE    # only transmitted to lavaan call = ok
  dotdotdot2$verbose <- FALSE  # only transmitted to lavaan call = ok
  dotdotdot2$auto.cov.lv.x <- TRUE # allow correlated exogenous factors

  # override with mm.options
  dotdotdot2 <- modifyList(dotdotdot2, mm.options)

  # we assume the same number/names of lv's per group!!!
  MM.FIT <- vector("list", nblocks)
  Sigma2.block <- vector("list", nblocks)
  for (b in 1:nblocks) {
    # create parameter table for this measurement block only
    PT.block <-
      lav_partable_subset_measurement_model(
        PT = PT,
        add.lv.cov = TRUE,
        lv.names = mm.list[[b]]
      )
    # fit 1-factor model
    fit.block <- do.call("lavaan",
      args = c(list(
        model = PT.block,
        data = data
      ), dotdotdot2)
    )
    # check convergence
    if (!lavInspect(fit.block, "converged")) {
      lav_msg_stop(
        gettextf("measurement model for %s did not converge.",
        lav_msg_view(mm.list[[b]]))
      )
    }
    # store fitted measurement model
    MM.FIT[[b]] <- fit.block

    # fs.method?
    if (fsr.method == "skrondal.laake") {
      # dependent -> Bartlett
      if (lv.names[b] %in% eqs.y.names) {
        fs.method <- "Bartlett"
      } else {
        fs.method <- "regression"
      }
    }

    # compute factor scores
    SC <- lavPredict(fit.block, method = fs.method, fsm = TRUE)
    FSM <- attr(SC, "fsm")
    attr(SC, "fsm") <- NULL

    # warning, FSM may be a list per pattern!
    # if(fit.block@Options$missing == "ml") {
    #    # do something...
    #    ngroups <- fit.block@Data@ngroups
    #    FSM.missing <- FSM
    #    FSM <- vector("list", length = "ngroups")
    #    for(g in seq_len(ngroups)) {
    #
    #    }
    # }

    LAMBDA <- lav_model_lambda(fit.block@Model) # FIXME: remove dummy lv's?
    THETA <- lav_model_theta(fit.block@Model) # FIXME: remove not used ov?
    PSI <- lav_model_veta(fit.block@Model)

    # if ngroups = 1, make list again
    if (ngroups == 1L) {
      # because lavPredict() drops the list
      SC <- list(SC)
    }

    # store results
    for (g in 1:ngroups) {
      FS.SCORES[[g]][[b]] <- SC[[g]]
      if (fsr.method %in% c("croon", "simple")) {
        offset <- FSM[[g]] %*% THETA[[g]] %*% t(FSM[[g]])
        scale <- FSM[[g]] %*% LAMBDA[[g]]
        scale.inv <- solve(scale)
        scoffset <- scale.inv %*% offset %*% scale.inv

        LVINFO[[g]][[b]] <- list(
          lv.names = mm.list[[b]],
          fsm = FSM[[g]],
          lambda = LAMBDA[[g]],
          psi = PSI[[g]],
          theta = THETA[[g]],
          offset = offset,
          scale = scale,
          scale.inv = scale.inv,
          scoffset = scoffset
        )
      }
    } # g

    # Delta.21: list per group
    Delta.21 <- lav_fsr_delta21(fit.block, FSM)

    # vcov
    Sigma1.block <- vcov(fit.block)
    tmp <- matrix(0, nrow(Delta.21[[1]]), nrow(Delta.21[[1]]))
    lavsamplestats <- fit.block@SampleStats
    for (g in 1:ngroups) {
      fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal
      tmp <-
        tmp + fg * (Delta.21[[g]] %*% Sigma1.block %*% t(Delta.21[[g]]))
    }
    Sigma2.block[[b]] <- tmp
  } # measurement block

  # Sigma.2 = Delta.21 %*% Sigma.1  %*% t(Delta.21)
  Sigma.2 <- lav_matrix_bdiag(Sigma2.block)


  # compute empirical covariance matrix factor scores + observed variables
  # in structural part
  group.values <- lav_partable_group_values(PT.PA)
  FS.COV <- vector("list", length = ngroups)
  FSR.COV <- vector("list", length = ngroups)
  FSR.COV2 <- vector("list", length = ngroups)
  Y <- vector("list", length = ngroups)
  if (lavoptions$meanstructure) {
    FS.MEAN <- vector("list", length = ngroups)
  } else {
    FS.MEAN <- NULL
  }
  for (g in seq_len(ngroups)) {
    # full data for structural model
    struc.names <- lav_object_vnames(PT.PA, "ov", group = group.values[g])
    # reorder struc.names, so that order is the same as in MM (new in 0.6-9)
    lv.idx <- which(struc.names %in% lv.names)
    struc.names[lv.idx] <- lv.names

    struc.ov.idx <- which(!struc.names %in% lv.names)
    struc.lv.idx <- which(struc.names %in% lv.names)
    lv.order <- match(lv.names, struc.names)
    if (length(struc.ov.idx) > 0L) {
      ov.idx <- which(FIT@Data@ov.names[[g]] %in%
        struc.names[struc.ov.idx])
      Y.g <- matrix(0,
        nrow = nrow(FS.SCORES[[g]][[1]]),
        ncol = length(struc.names)
      )
      Y.g[, struc.lv.idx] <- do.call(
        "cbind",
        FS.SCORES[[g]]
      )[, lv.order, drop = FALSE]
      Y.g[, struc.ov.idx] <- FIT@Data@X[[g]][, ov.idx, drop = FALSE]
    } else {
      Y.g <- do.call("cbind", FS.SCORES[[g]])[, lv.order, drop = FALSE]
    }
    Y[[g]] <- Y.g

    # sample statistics for structural model
    COV <- cov(Y.g) # divided by N-1
    if (lavoptions$likelihood == "normal") {
      Ng <- lavInspect(FIT, "nobs")[g]
      COV <- COV * (Ng - 1) / Ng
    }
    FS.COV[[g]] <- COV

    if (lavoptions$meanstructure) {
      FS.MEAN[[g]] <- colMeans(Y.g)
    }

    # STEP 1b: if using `Croon' method: correct COV matrix:
    if (fsr.method %in% c("croon")) {
      scoffset <- lav_matrix_bdiag(lapply(LVINFO[[g]], "[[", "scoffset"))
      scale.inv <- lav_matrix_bdiag(lapply(LVINFO[[g]], "[[", "scale.inv"))

      SCOFFSET <- matrix(0,
        nrow = length(struc.names),
        ncol = length(struc.names)
      )
      SCOFFSET[struc.lv.idx, struc.lv.idx] <- scoffset

      SCALE.INV <- diag(length(struc.names))
      SCALE.INV[struc.lv.idx, struc.lv.idx] <- scale.inv

      FSR.COV[[g]] <- SCALE.INV %*% FS.COV[[g]] %*% SCALE.INV - SCOFFSET
    } else if (fsr.method == "simple") {
      psi <- lav_matrix_bdiag(lapply(LVINFO[[g]], "[[", "psi"))

      FSR.COV[[g]] <- FS.COV[[g]]
      # scalar version only (for now)
      diag(FSR.COV[[g]])[struc.lv.idx] <- psi
    } else {
      FSR.COV[[g]] <- FS.COV[[g]]
    }

    # copy with different labels
    FSR.COV2[[g]] <- FSR.COV[[g]]

    # add row/col names
    rownames(FS.COV[[g]]) <- colnames(FS.COV[[g]]) <- struc.names
    rownames(FSR.COV[[g]]) <- colnames(FSR.COV[[g]]) <- struc.names
    rownames(FSR.COV2[[g]]) <- colnames(FSR.COV2[[g]]) <- struc.names
    rownames(FSR.COV2[[g]])[struc.lv.idx] <-
      colnames(FSR.COV2[[g]])[struc.lv.idx] <-
      paste(lv.names, ".si", sep = "")

    # check if FSR.COV is positive definite for all groups
    eigvals <- eigen(FSR.COV[[g]], symmetric = TRUE, only.values = TRUE)$values
    if (any(eigvals < .Machine$double.eps^(3 / 4))) {
      if (ngroups > 1L) {
        lav_msg_stop(gettextf("corrected covariance matrix of factor scores
                               is not positive definite in group %s", g))

      } else {
        lav_msg_stop(gettext("corrected covariance matrix of factor scores
                              is not positive definite"))
      }
    }
  } # g


  # STEP 1c: do we need full set of factor scores?
  if (fs.scores) {
    # transform?
    if (fsr.method %in% c("croon", "simple")) {
      for (g in 1:ngroups) {
        OLD.inv <- solve(FS.COV[[g]])
        OLD.inv.sqrt <- lav_matrix_symmetric_sqrt(OLD.inv)
        FSR.COV.sqrt <- lav_matrix_symmetric_sqrt(FSR.COV[[g]])
        SC <- as.matrix(Y[[g]])
        SC <- SC %*% OLD.inv.sqrt %*% FSR.COV.sqrt
        SC <- as.data.frame(SC)
        names(SC) <- lv.names
        Y[[g]] <- SC
      }
    }

    # unlist if multiple groups, add group column
    if (ngroups == 1L) {
      Y <- as.data.frame(Y[[1]])
    } else {
      lav_msg_fixme("fix this!")
    }
  }




  # STEP 2: fit structural model using (corrected?) factor scores

  # free all means/intercepts (of observed variables only)
  lv.names.pa <- lav_object_vnames(PT.PA, "lv")
  int.idx <- which(PT.PA$op == "~1" & !PT.PA$lhs %in% lv.names.pa)
  PT.PA$free[int.idx] <- 1L
  PT.PA$free[PT.PA$free > 0L] <- seq_len(sum(PT.PA$free > 0L))
  PT.PA$ustart[int.idx] <- NA



  # adjust lavoptions
  if (is.null(dotdotdot$do.fit)) {
    lavoptions$do.fit <- TRUE
  } else {
    lavoptions$do.fit <- dotdotdot$do.fit
  }
  if (is.null(dotdotdot$se)) {
    lavoptions$se <- "standard"
  } else {
    lavoptions$se <- dotdotdot$se
  }
  if (is.null(dotdotdot$test)) {
    lavoptions$test <- "standard"
  } else {
    lavoptions$test <- dotdotdot$test
  }
  if (is.null(dotdotdot$sample.cov.rescale)) {
    lavoptions$sample.cov.rescale <- FALSE
  } else {
    lavoptions$sample.cov.rescale <- dotdotdot$sample.cov.rescale
  }

  # fit structural model -- point estimation ONLY
  lavoptions2 <- lavoptions
  # if(lavoptions$se == "standard") {
  #    lavoptions2$se <- "external"
  # }
  # lavoptions2$test <- "none"
  lavoptions2$se <- "none"
  lavoptions2$test <- "none"
  lavoptions2$missing <- "listwise" # always complete data anyway...
  fit <- lavaan(PT.PA,
    sample.cov = FSR.COV,
    sample.mean = FS.MEAN,
    sample.nobs = FIT@SampleStats@nobs,
    slotOptions = lavoptions2
  )

  # only to correct the SE, we create another model, augmented with
  # the croon parameters
  PT.PA2 <- parTable(fit)
  PT.si <- lav_fsr_pa2si(PT.PA2, LVINFO = LVINFO)
  idx1 <- PT.si$free[PT.si$user == 10L & PT.si$free > 0L]
  idx2 <- PT.si$free[PT.si$user != 10L & PT.si$free > 0L]

  lavoptions3 <- lavoptions2
  lavoptions3$optim.method <- "none"
  lavoptions3$test <- "standard"
  lavoptions3$se <- "none"
  lavoptions3$check.gradient <- FALSE
  lavoptions3$information <- "expected" ## FIXME: lav_model_gradient + delta
  fit.si2 <- lavaan(PT.si,
    sample.cov  = FSR.COV2,
    sample.mean = FS.MEAN,
    sample.nobs = FIT@SampleStats@nobs,
    slotOptions = lavoptions3
  )
  Info.all <- lavTech(fit.si2, "information") * nobs(fit)
  I33 <- Info.all[idx2, idx2]
  I32 <- Info.all[idx2, idx1]
  I23 <- Info.all[idx1, idx2]
  I22 <- Info.all[idx1, idx1]

  I33.inv <- lav_matrix_symmetric_inverse(I33)

  V1 <- I33.inv
  V2 <- I33.inv %*% I32 %*% Sigma.2 %*% t(I32) %*% I33.inv
  VCOV <- V1 + V2

  # fill in standard errors step 2
  PT.PA2$se[PT.PA2$free > 0L] <- sqrt(diag(VCOV))

  if (output == "lavaan" || output == "fsr") {
    lavoptions3$se <- "twostep"
    fit <- lavaan::lavaan(PT.PA2,
      sample.cov = FSR.COV,
      sample.mean = FS.MEAN,
      sample.nobs = FIT@SampleStats@nobs,
      slotOptions = lavoptions3
    )
    fit@vcov$vcov <- VCOV
  }

  # extra info
  extra <- list(
    FS.COV = FS.COV, FS.SCORES = Y,
    FSR.COV = FSR.COV,
    LVINFO = LVINFO, Sigma.2 = Sigma.2
  )

  # standard errors
  # lavsamplestats <- fit@SampleStats
  # lavsamplestats@NACOV <- Omega.f
  # VCOV <- lav_model_vcov(fit@Model, lavsamplestats = lavsamplestats,
  #                       lavoptions = lavoptions)
  # SE <- lav_model_vcov_se(fit@Model, fit@ParTable, VCOV = VCOV)
  # PE$se <- SE
  # tmp.se <- ifelse(PE$se == 0.0, NA, PE$se)
  # zstat <- pvalue <- TRUE
  # if(zstat) {
  #    PE$z <- PE$est / tmp.se
  #    if(pvalue) {
  #        PE$pvalue <- 2 * (1 - pnorm( abs(PE$z) ))
  #    }
  # }

  if (output == "fsr") {
    HEADER <- paste("This is fsr (0.2) -- factor score regression using ",
      "fsr.method = ", fsr.method,
      sep = ""
    )
    out <- list(header = HEADER, MM.FIT = MM.FIT, STRUC.FIT = fit)
    if (lvinfo) {
      out$lvinfo <- extra
    }

    class(out) <- c("lavaan.fsr", "list")
  } else if (output %in% c("lavaan", "fit")) {
    out <- fit
  } else if (output == "extra") {
    out <- extra
  } else if (output == "lvinfo") {
    out <- LVINFO
  } else if (output %in% c("scores", "f.scores", "fs.scores")) {
    out <- Y
  } else if (output %in% c(
    "FSR.COV", "fsr.cov", "croon", "cov.croon",
    "croon.cov", "COV", "cov"
  )) {
    out <- FSR.COV
  } else if (output %in% c("FS.COV", "fs.cov")) {
    out <- FS.COV
  } else {
    lav_msg_stop(gettext("unknown output= argument:"), output)
  }

  out
}

#' lav_export_estimation
#'
#' lavaan provides a range of optimization methods with the optim.method argument
#' (nlminb, BFGS, L-BFGS-B, GN, and nlminb.constr). `lav_export_estimation`
#' allows exporting objects and functions necessary to pass a lavaan model into
#' any optimizer that takes a combination of (1) starting values, (2) fit-function,
#' (3) gradient-function, and (4) upper and lower bounds. This allows testing new
#' optimization frameworks.
#'
#' @param lavaan_model a fitted lavaan model
#' @returns List with:
#' \itemize{
#'   \item get_coef - When working with equality constraints, lavaan internally
#'   uses some transformations. get_coef is a functions that recreates the coef
#'   function for the parameters.
#'   \item starting_values - starting_values to be used in the optimization
#'   \item objective_function - objective function, expecting the current parameter
#'   values and the lavaan model
#'   \item gradient_function - gradient function, expecting the current parameter
#'   values and the lavaan model
#'   \item lower - lower bounds for parameters
#'   \item upper - upper bound for parameters
#' }
#' @export
#' @examples
#' library(lavaan)
#' model <- "
#'   # latent variable definitions
#'      ind60 =~ x1 + x2 + x3
#'      dem60 =~ y1 + y2 + y3 + y4
#'      dem65 =~ y5 + a*y6 + y7 + y8
#'
#'   # regressions
#'     dem60 ~ ind60
#'     dem65 ~ ind60 + dem60
#' "
#'
#' fit <- sem(model,
#'   data = PoliticalDemocracy,
#'   do.fit = FALSE
#' )
#'
#' est <- lav_export_estimation(lavaan_model = fit)
#'
#' # The starting values are:
#' est$starting_values
#' # Note that these do not have labels (and may also differ from coef(fit)
#' # in case of equality constraints):
#' coef(fit)
#' # To get the same parameters, use:
#' est$get_coef(
#'   parameter_values = est$starting_values,
#'   lavaan_model = fit
#' )
#'
#' # The objective function can be used to compute the fit at the current estimates:
#' est$objective_function(
#'   parameter_values = est$starting_values,
#'   lavaan_model = fit
#' )
#'
#' # The gradient function can be used to compute the gradients at the current estimates:
#' est$gradient_function(
#'   parameter_values = est$starting_values,
#'   lavaan_model = fit
#' )
#'
#' # Together, these elements provide the means to estimate the parameters with a large
#' # range of optimizers. For simplicity, here is an example using optim:
#' est_fit <- optim(
#'   par = est$starting_values,
#'   fn = est$objective_function,
#'   gr = est$gradient_function,
#'   lavaan_model = fit,
#'   method = "BFGS"
#' )
#' est$get_coef(
#'   parameter_values = est_fit$par,
#'   lavaan_model = fit
#' )
#'
#' # This is identical to
#' coef(sem(model,
#'   data = PoliticalDemocracy
#' ))
#'
#' # Example using ridge regularization for parameter a
#' fn_ridge <- function(parameter_values, lavaan_model, est, lambda) {
#'   return(est$objective_function(
#'     parameter_values = parameter_values,
#'     lavaan_model = lavaan_model
#'   ) + lambda * parameter_values[6]^2)
#' }
#' ridge_fit <- optim(
#'   par = est$get_coef(est$starting_values,
#'     lavaan_model = fit
#'   ),
#'   fn = fn_ridge,
#'   lavaan_model = fit,
#'   est = est,
#'   lambda = 10
#' )
#' est$get_coef(
#'   parameter_values = ridge_fit$par,
#'   lavaan_model = fit
#' )
lav_export_estimation <- function(lavaan_model) {
  # define objective function
  objective_function <- function(parameter_values,
                                 lavaan_model) {
    if (lavaan_model@Model@eq.constraints) {
      parameter_values <- as.numeric(lavaan_model@Model@eq.constraints.K %*% parameter_values) +
        lavaan_model@Model@eq.constraints.k0
    }

    # create group list
    GLIST <- lav_model_x2glist(lavaan_model@Model, x = parameter_values)
    # get objective function **value**
    fx <- lav_model_objective(
      lavmodel = lavaan_model@Model,
      GLIST = GLIST,
      lavsamplestats = lavaan_model@SampleStats,
      lavdata = lavaan_model@Data,
      lavcache = list()
    )
    if (lavaan_model@Options$estimator == "PML") {
      # rescale objective function value
      fx <- fx / lavaan_model@SampleStats@ntotal
    }

    if (!is.finite(fx)) {
      fx.group <- attr(fx, "fx.group")
      fx <- 1e+20
      attr(fx, "fx.group") <- fx.group
    }
    return(fx)
  }

  # define gradient function
  gradient_function <- function(parameter_values,
                                lavaan_model) {
    if (lavaan_model@Model@eq.constraints) {
      parameter_values <- as.numeric(lavaan_model@Model@eq.constraints.K %*% parameter_values) +
        lavaan_model@Model@eq.constraints.k0
    }

    GLIST <- lav_model_x2glist(lavaan_model@Model,
      x = parameter_values
    )
    current.verbose <- lav_verbose()
    if (lav_verbose(FALSE))
      on.exit(lav_verbose(current.verbose), TRUE)
    dx <- lav_model_gradient(
      lavmodel = lavaan_model@Model,
      GLIST = GLIST,
      lavsamplestats = lavaan_model@SampleStats,
      lavdata = lavaan_model@Data,
      lavcache = list(),
      type = "free",
      group.weight = !(lavaan_model@SampleStats@missing.flag || lavaan_model@Options$estimator == "PML"),
      ceq.simple = lavaan_model@Model@ceq.simple.only
    )
    lav_verbose(current.verbose)

    if (lavaan_model@Model@eq.constraints) {
      dx <- as.numeric(dx %*% lavaan_model@Model@eq.constraints.K)
    }
    if (lavaan_model@Options$estimator == "PML") {
      dx <- dx / lavaan_model@SampleStats@ntotal
    }
    return(dx)
  }

  # extract bounds
  lower <- lavaan_model@ParTable$lower[lavaan_model@ParTable$free > 0L]
  upper <- lavaan_model@ParTable$upper[lavaan_model@ParTable$free > 0L]

  # get starting values
  starting_values <- lav_model_get_parameters(lavaan_model@Model)
  if (lavaan_model@Model@eq.constraints) {
    starting_values <- as.numeric((starting_values - lavaan_model@Model@eq.constraints.k0) %*%
      lavaan_model@Model@eq.constraints.K)
  }

  # lavaan internally uses transformations when there are equality constraints.
  # As a result, the parameters are not necessarily those one would expect when
  # fitting the model. The parameters can be translated with the following function:
  get_coef <- function(parameter_values,
                       lavaan_model) {
    if (lavaan_model@Model@eq.constraints) {
      parameter_values <- as.numeric(lavaan_model@Model@eq.constraints.K %*% parameter_values) +
        lavaan_model@Model@eq.constraints.k0
    }
    names(parameter_values) <- lav_partable_labels(lavaan_model@ParTable,
      type = "free"
    )
    return(parameter_values)
  }

  # Now we just return everything so that the user can use their own optimizer
  return(
    list(
      get_coef = get_coef,
      starting_values = starting_values,
      objective_function = objective_function,
      gradient_function = gradient_function,
      lower = lower,
      upper = upper
    )
  )
}

lav_lavaan_step03_data <- function(slotData = NULL, # nolint
                                   lavoptions = NULL,
                                   ov.names = NULL,
                                   ov.names.y = NULL,
                                   group = NULL,
                                   data = NULL,
                                   cluster = NULL,
                                   ov.names.x = NULL,
                                   ov.names.l = NULL,
                                   ordered = NULL,
                                   sampling.weights = NULL,
                                   sample.cov = NULL,
                                   sample.mean = NULL,
                                   sample.th = NULL,
                                   sample.nobs = NULL,
                                   slotParTable = NULL, # nolint
                                   ngroups = NULL,
                                   dotdotdot = NULL,
                                   flat.model = NULL,
                                   model = NULL,
                                   NACOV = NULL, # nolint
                                   WLS.V = NULL) { # nolint
  # # # # # # # # # # #
  # #  3. lavdata  # #
  # # # # # # # # # # #

  # if slotData not null
  #   copy slotData to lavdata
  # else
  #   create lavdata via function lav_lavdata, setting ov.names to ov.names.y
  #     if lavoptions$conditional.x
  # if lavdata$data.type is "none"
  #   set lavoptions$do.fit to FALSE
  #   if flat.model$est not null set lavoptions$start to "est", else set
  #     it to "simple"
  #   set lavoptions$se and lavoptions$test to "none"
  # else
  #   if lavdata$data.type is "moment"
  #     if estimator one of MLM, MLMV, MLR, ULSM, ULSMV, ULSMVS and NACOV
  #       is NULL: *** error ***
  #     if estimator one of WLS, WLSM, WLSMV, WLSMVS, DWLS and WLS.V is
  #       NULL: *** error ***
  #     if lavoptions$se = bootstrap: *** error ***
  # if slotPartable not NULL and model is lavaan-object, check equality
  #   ngroups and lavdata$ngroups
  #                                       --> *** error *** if not

  if (!is.null(slotData)) {
    lavdata <- slotData
  } else {
    if (lav_verbose()) {
      cat("lavdata            ...")
    }
    # FIXME: ov.names should always contain both y and x!
    tmp.ov.names <- if (lavoptions$conditional.x) {
      ov.names.y
    } else {
      ov.names
    }
    lavdata <- lav_lavdata(
      data = data,
      group = group,
      cluster = cluster,
      ov.names = tmp.ov.names,
      ov.names.x = ov.names.x,
      ov.names.l = ov.names.l,
      ordered = ordered,
      sampling.weights = sampling.weights,
      sample.cov = sample.cov,
      sample.mean = sample.mean,
      sample.th = sample.th,
      sample.nobs = sample.nobs,
      lavoptions = lavoptions
    )

    if (lav_verbose()) {
      cat(" done.\n")
    }
  }
  # what have we learned from the data?
  if (lavdata@data.type == "none") {
    lavoptions$do.fit <- FALSE
    # check if 'model' was a fitted parameter table
    lavoptions$start <- ifelse(is.null(flat.model$est), "simple", "est")
    lavoptions$se <- "none"
    lavoptions$test <- "none"
  } else if (lavdata@data.type == "moment") {
    # check user-specified options first
    if (!is.null(dotdotdot$estimator)) {
      if (any(dotdotdot$estimator == c(
        "MLM", "MLMV", "MLR", "MLR",
        "ULSM", "ULSMV", "ULSMVS"
      )) &&
        is.null(NACOV)) {
        lav_msg_stop(gettextf(
          "estimator %s requires full data or user-provided NACOV",
          dotdotdot$estimator))
      } else if (any(dotdotdot$estimator == c(
        "WLS", "WLSM", "WLSMV",
        "WLSMVS", "DWLS"
      )) &&
        is.null(WLS.V)) {
        lav_msg_stop(gettextf(
          "estimator %s requires full data or user-provided WLS.V and NACOV",
          dotdotdot$estimator))
      }
    }
    # catch here some options that will not work with moments
    if (lavoptions$se == "bootstrap") {
      lav_msg_stop(gettext("bootstrapping requires full data"))
    }
    # more needed?
  }
  # sanity check
  if (!is.null(slotParTable) || inherits(model, "lavaan")) {
    if (ngroups != lavdata@ngroups) {
      lav_msg_stop(gettext(
        "mismatch between number of groups in data
        and number of groups in model."))
    }
  }
  if (lav_verbose()) {
    print(lavdata)
  }
  if (lav_debug()) {
    print(str(lavdata))
  }
  # if lavdata@nlevels > 1L, adapt start option (for now)
  # until we figure out how to handle groups+blocks
  # if(lavdata@nlevels > 1L) {
  #   lavoptions$start <- "simple"
  # }

  list(
    lavdata    = lavdata,
    lavoptions = lavoptions
  )
}

# compute sample statistics for the unrestricted (h1) model
# and also the logl (if available)
lav_h1_implied_logl <- function(lavdata = NULL,
                                lavsamplestats = NULL,
                                lavpartable = NULL, # multilevel + missing
                                lavoptions = NULL) {
  lavpta <- NULL
  if (!is.null(lavpartable)) {
    lavpta <- lav_partable_attributes(lavpartable)
    lavpartable <- lav_partable_set_cache(lavpartable, lavpta)
  }

  # single-level case
  if (lavdata@nlevels == 1L) {

    # missing data
    if (lavsamplestats@missing.flag) {
      if (lavoptions$conditional.x) {
        implied <- list() # not available yet
      } else {
        implied <- list(
          cov = lavsamplestats@cov,
          mean = lavsamplestats@mean,
          th = lavsamplestats@th,
          group.w = lavsamplestats@group.w
        )
        # insert ML estimates
        for (g in 1:lavdata@ngroups) {
          # zero coverage?
          if (any(lav_matrix_vech(lavdata@Mp[[g]]$coverage,
                                  diagonal = FALSE) == 0L)) {
            out <- lav_mvnorm_missing_h1_estimate_moments_chol(
              lavdata = lavdata, lavsamplestats = lavsamplestats,
              lavoptions = lavoptions, group = g)
            implied$cov[[g]] <- out$Sigma
            implied$mean[[g]] <- out$Mu
          } else {
            # regular EM estimates
            implied$cov[[g]] <- lavsamplestats@missing.h1[[g]]$sigma
            implied$mean[[g]] <- lavsamplestats@missing.h1[[g]]$mu
          }
        }
      }

    # complete data
    } else {
      if (lavoptions$conditional.x) {
        implied <- list(
          res.cov = lavsamplestats@res.cov,
          res.int = lavsamplestats@res.int,
          res.slopes = lavsamplestats@res.slopes,
          cov.x = lavsamplestats@cov.x,
          mean.x = lavsamplestats@mean.x,
          res.th = lavsamplestats@res.th,
          group.w = lavsamplestats@group.w
        )
      } else {
        implied <- list(
          cov = lavsamplestats@cov,
          mean = lavsamplestats@mean,
          th = lavsamplestats@th,
          group.w = lavsamplestats@group.w
        )
      }
    } # complete data

    logl <- lav_h1_logl(
      lavdata = lavdata,
      lavsamplestats = lavsamplestats,
      h1.implied = implied,
      lavoptions = lavoptions
    )
  } else {
    # estimate Mu.B, Mu.W, Sigma.B and Sigma.W for unrestricted model
    ngroups <- lavdata@ngroups
    nlevels <- lavdata@nlevels
    implied <- list(
      cov = vector("list", length = ngroups * nlevels),
      mean = vector("list", length = ngroups * nlevels)
    )
    loglik.group <- numeric(lavdata@ngroups)

    for (g in 1:lavdata@ngroups) {
      if (lav_verbose()) {
        cat("\n\nfitting unrestricted (H1) model in group ", g, "\n")
      }
      if (lavsamplestats@missing.flag) {
        # missing data

        # 1. first a few EM iteration faking complete data
        # Y1 <- lavdata@X[[g]]
        # cluster.idx <- lavdata@Lp[[g]]$cluster.idx[[2]]
        # Y2.complete <- unname(as.matrix(aggregate(Y1,
        #                by = list(cluster.idx),
        #                FUN = function(x) {
        #                    if( all(is.na(x)) ) { # all elements are NA
        #                        as.numeric(0)     # in this cluster
        #                    } else {
        #                        mean(x, na.rm = TRUE)
        #                    }
        #                })[,-1]))
        # YLp = lavsamplestats@YLp[[g]]
        # YLp[[2]]$Y2 <- Y2.complete
        # OUT <- lav_mvnorm_cluster_em_sat(
        #    YLp      = YLp,
        #    Lp       = lavdata@Lp[[g]],
        #    verbose  = TRUE, # for now
        #    tol      = 1e-04,
        #    min.variance = 1e-05,
        #    max.iter = 5L)
        ## create tmp lav1, only for this group
        # implied$cov[[ (g-1)*nlevels + 1L]] <- OUT$Sigma.W
        # implied$cov[[ (g-1)*nlevels + 2L]] <- OUT$Sigma.B
        # implied$mean[[(g-1)*nlevels + 1L]] <- OUT$Mu.W
        # implied$mean[[(g-1)*nlevels + 2L]] <- OUT$Mu.B
        # loglik.group[g] <- OUT$logl
        # lavh1 <- list(implied = implied, logl = sum(loglik.group))
        # lavpartable <- lav_partable_unrestricted(lavdata = lavdata,
        #     lavsamplestats = lavsamplestats, lavoptions = lavoptions,
        #     lavpta = lavpta, lavh1 = lavh1)
        # lavpartable$lower <- rep(-Inf, length(lavpartable$lhs))
        # var.idx <- which(lavpartable$free > 0L &
        #                 lavpartable$op == "~~" &
        #                 lavpartable$lhs == lavpartable$rhs)
        # lavpartable$lower[var.idx] <- 1e-05

        lavpartable <- lav_partable_unrestricted_chol(
          lavdata = lavdata,
          lavoptions = lavoptions, lavpta = lavpta
        )

        lavoptions2 <- lavoptions
		lavoptions2$estimator <- "ML"
        lavoptions2$se <- "none"
        lavoptions2$test <- "none"
        lavoptions2$do.fit <- TRUE
		lavoptions2$optim.method <- "nlminb"
        lavoptions2$h1 <- FALSE
		lavoptions2$implied <- TRUE
		lavoptions2$loglik <- TRUE
        lavoptions2$baseline <- FALSE
        lavoptions2$fixed.x <- FALSE # even if model uses fixed.x=TRUE
        lavoptions2$model.type <- "unrestricted"
        lavoptions2$optim.attempts <- 4L
        lavoptions2$check.gradient <- FALSE
        lavoptions2$optim.force.convergence <- TRUE # for now...
        lavoptions2$control <- list(rel.tol = 1e-7)
        # FIT <- lavaan(lavpartable, slotOptions = lavoptions2,
        #          slotSampleStats = lavsamplestats,
        #          slotData = lavdata, sloth1 = lavh1)
        FIT <- lavaan(lavpartable,
          slotOptions = lavoptions2,
          slotSampleStats = lavsamplestats,
          slotData = lavdata,
          warn = FALSE
        )
        OUT <- list(
          Sigma.W = FIT@implied$cov[[1]],
          Sigma.B = FIT@implied$cov[[2]],
          Mu.W = FIT@implied$mean[[1]],
          Mu.B = FIT@implied$mean[[2]],
          logl = FIT@loglik$loglik
        )
        # if(lavoptions$fixed.x) {
        #   OUT$logl <- OUT$logl - lavsamplestats@YLp[[g]][[2]]$loglik.x
        # }
      } else {
        # complete data
        OUT <- lav_mvnorm_cluster_em_sat(
          YLp = lavsamplestats@YLp[[g]],
          Lp = lavdata@Lp[[g]],
          tol = 1e-04, # option?
          min.variance = 1e-05, # option?
          max.iter = 5000L
        ) # option?
      }
      if (lav_verbose()) {
        cat("\n")
      }

      # if any near-zero within variance(s), produce warning here
      zero.var <- which(diag(OUT$Sigma.W) <= 1e-05)
      if (length(zero.var)) {
        gtxt <- if (ngroups > 1L) {
          gettextf(" in group %s.", g)
        } else {
          " "
        }
        lav_msg_warn(gettextf(
          "H1 estimation resulted in a within covariance matrix %1$s with
          (near) zero variances for some of the level-1 variables: %2$s",
            gtxt, lav_msg_view(lavdata@ov.names.l[[g]][[1]][zero.var]))
        )
      }

      # new in 0.6-18: ensure Mu.W[both.idx] is zero (post-estimation!)
      # (not correctly; fixed in 0.6-19...)
      both.idx   <- lavdata@Lp[[g]]$both.idx[[2]]
      within.idx <- lavdata@Lp[[g]]$within.idx[[2]]
      ov.idx     <- lavdata@Lp[[g]]$ov.idx
      p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]])))
      Mu.W.tilde <- Mu.B.tilde <- Mu.WB.tilde <- numeric(p.tilde)
      Mu.W.tilde[ov.idx[[1]]] <- OUT$Mu.W
      Mu.B.tilde[ov.idx[[2]]] <- OUT$Mu.B
      Mu.WB.tilde[both.idx  ] <- (Mu.B.tilde[both.idx] + Mu.W.tilde[both.idx])
      Mu.W.tilde[both.idx] <- 0
      Mu.B.tilde[both.idx] <- Mu.WB.tilde[both.idx]
      OUT$Mu.W <- Mu.W.tilde[ ov.idx[[1]] ]
      OUT$Mu.B <- Mu.B.tilde[ ov.idx[[2]] ]

      # store in implied
      implied$cov[[ (g - 1) * nlevels + 1L]] <- OUT$Sigma.W
      implied$cov[[ (g - 1) * nlevels + 2L]] <- OUT$Sigma.B
      implied$mean[[(g - 1) * nlevels + 1L]] <- OUT$Mu.W
      implied$mean[[(g - 1) * nlevels + 2L]] <- OUT$Mu.B

      # store logl per group
      loglik.group[g] <- OUT$logl
    }

    logl <- list(loglik = sum(loglik.group), loglik.group = loglik.group)
  }

  list(implied = implied, logl = logl)
}

# lavaanList: fit the *same* model, on different datasets
# YR - 29 Jun 2016
# YR - 27 Jan 2017: change lavoptions; add dotdotdot to each call
# TDJ - 23 Aug 2018: change wrappers to preserve arguments from match.call()
# YR - 15 Oct 2024: add iseed (as in lavBootstrap)

lavaanList <- function(model = NULL, # model
                       dataList = NULL, # list of datasets
                       dataFunction = NULL, # generating function
                       dataFunction.args = list(), # optional arguments
                       ndat = length(dataList), # how many datasets?
                       cmd = "lavaan",
                       ...,
                       store.slots = c("partable"), # default is partable
                       FUN = NULL, # arbitrary FUN
                       show.progress = FALSE,
                       store.failed = FALSE,
                       parallel = c("no", "multicore", "snow"),
                       ncpus = max(1L, parallel::detectCores() - 1L),
                       cl = NULL,
                       iseed = NULL) {
  # store.slots call
  mc <- match.call()

  # store current random seed (if any) and method
  RNGkind_old <- RNGkind()
  #cat("RNGkind = ", paste(RNGkind_old, collapse = " "), "\n")
  if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
    init.seed <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
  } else {
    init.seed <- NULL
  }

  # initial seed (for the precomputations)
  if (!is.null(iseed)) {
    set.seed(min(1, iseed - 1L))
  }

  # check store.slots
  store.slots <- tolower(store.slots)
  if (length(store.slots) == 1L && store.slots == "all") {
    store.slots <- c(
      "timing", "partable", "data", "samplestats",
      "cache", "loglik", "h1", "baseline", "external",
      "vcov", "test", "optim", "implied"
    )
  }

  # dataList or function?
  if (is.function(dataFunction)) {
    if (ndat == 0L) {
      lav_msg_stop(gettext("please specify number of requested datasets (ndat)"))
    }
    # here we already use the random generator
    firstData <- do.call(dataFunction, args = dataFunction.args)
    # dataList  <- vector("list", length = ndat)
  } else {
    firstData <- dataList[[1]]
  }

  # check data
  if (is.matrix(firstData)) {
    # check if we have column names?
    NAMES <- colnames(firstData)
    if (is.null(NAMES)) {
      lav_msg_stop(gettext("data is a matrix without column names"))
    }
  } else if (inherits(firstData, "data.frame")) {
    # check?
  } else {
    lav_msg_stop(gettext("(generated) data is not a data.frame (or a matrix)"))
  }

  # dot dot dot
  dotdotdot <- list(...)

  # if 'model' is a lavaan object (perhaps from lavSimulate), no need to
  # call `cmd'
  if (inherits(model, "lavaan")) {
    FIT <- model
  } else {
    # adapt for FIT
    # dotdotdotFIT <- dotdotdot
    # dotdotdotFIT$do.fit  <- TRUE    # to get starting values
    # dotdotdotFIT$se      <- "none"
    # dotdotdotFIT$test    <- "none"

    # initial model fit, using first dataset
    FIT <- do.call(cmd,
      args = c(list(
        model = model,
        data = firstData
      ), dotdotdot)
    )
  }

  lavoptions <- FIT@Options
  lavmodel <- FIT@Model
  lavpartable <- FIT@ParTable
  lavpta <- FIT@pta

  # remove any options in lavoptions from dotdotdot (sem/lavaan only)
  # because we can use the lavoptions slot
  if (length(dotdotdot) > 0L && cmd %in% c("lavaan", "sem", "cfa", "growth")) {
    rm.idx <- which(names(dotdotdot) %in% names(lavoptions))
    if (length(rm.idx) > 0L) {
      dotdotdot <- dotdotdot[-rm.idx]
    }
  }

  # remove start/est/se columns from lavpartable
  lavpartable$start <- lavpartable$est <- lavpartable$se <- NULL

  # empty slots
  timingList <- ParTableList <- DataList <- SampleStatsList <-
    CacheList <- vcovList <- testList <- optimList <-
    h1List <- loglikList <- baselineList <-
    impliedList <- funList <- list()

  # prepare store.slotsd slots
  if ("timing" %in% store.slots) {
    timingList <- vector("list", length = ndat)
  }
  if ("partable" %in% store.slots) {
    ParTableList <- vector("list", length = ndat)
  }
  if ("data" %in% store.slots) {
    DataList <- vector("list", length = ndat)
  }
  if ("samplestats" %in% store.slots) {
    SampleStatsList <- vector("list", length = ndat)
  }
  if ("cache" %in% store.slots) {
    CacheList <- vector("list", length = ndat)
  }
  if ("vcov" %in% store.slots) {
    vcovList <- vector("list", length = ndat)
  }
  if ("test" %in% store.slots) {
    testList <- vector("list", length = ndat)
  }
  if ("optim" %in% store.slots) {
    optimList <- vector("list", length = ndat)
  }
  if ("implied" %in% store.slots) {
    impliedList <- vector("list", length = ndat)
  }
  if ("loglik" %in% store.slots) {
    loglikList <- vector("list", length = ndat)
  }
  if ("h1" %in% store.slots) {
    h1List <- vector("list", length = ndat)
  }
  if ("baseline" %in% store.slots) {
    baselineList <- vector("list", length = ndat)
  }

  if (!is.null(FUN)) {
    funList <- vector("list", length = ndat)
  }

  # single run
  fn <- function(i) {
    if (show.progress) {
      cat("   ... data set number:", sprintf("%4d", i))
    }

    # get new dataset
    if (i == 1L) {
      DATA <- firstData
    } else if (is.function(dataFunction)) {
      DATA <- do.call(dataFunction, args = dataFunction.args)
    } else if (is.list(dataList)) {
      DATA <- dataList[[i]]
    }

    # if categorical, check if we have enough response categories
    # for each ordered variables in DATA
    data.ok.flag <- TRUE
    if (FIT@Model@categorical) {
      # expected nlev
      ord.idx <- unique(unlist(FIT@pta$vidx$ov.ord))
      NLEV.exp <- FIT@Data@ov$nlev[ord.idx]
      # observed nlev
      NLEV.obs <- sapply(
        DATA[, unique(unlist(FIT@pta$vnames$ov.ord)),
          drop = FALSE
        ],
        function(x) length(unique(na.omit(x)))
      )
      wrong.idx <- which(NLEV.exp - NLEV.obs != 0)
      if (length(wrong.idx) > 0L) {
        data.ok.flag <- FALSE
      }
    }

    # adapt lavmodel for this new dataset
    # - starting values will be different
    # - ov.x variances/covariances
    # FIXME: can we not make the changes internally?
    # if(lavmodel@fixed.x && length(lav_partable_vnames(lavpartable, "ov.x")) > 0L) {
    # for(g in 1:FIT@Data@ngroups) {
    #
    # }
    lavmodel <- NULL
    # }

    # fit model with this (new) dataset
    if (data.ok.flag) {
      if (cmd %in% c("lavaan", "sem", "cfa", "growth")) {
        # lavoptions$start <- FIT # FIXME: needed?
        lavobject <- try(
          do.call("lavaan",
            args = c(
              list(
                slotOptions = lavoptions,
                slotParTable = lavpartable,
                slotModel = lavmodel,
                # start        = FIT,
                data = DATA
              ),
              dotdotdot
            )
          ),
          silent = TRUE
        )
      } else if (cmd == "fsr") {
        # extract fs.method and fsr.method from dotdotdot
        if (!is.null(dotdotdot$fs.method)) {
          fs.method <- dotdotdot$fs.method
        } else {
          fs.method <- formals(fsr)$fs.method # default
        }

        if (!is.null(dotdotdot$fsr.method)) {
          fsr.method <- dotdotdot$fsr.method
        } else {
          fsr.method <- formals(fsr)$fsr.method # default
        }

        lavoptions$start <- FIT # FIXME: needed?
        lavobject <- try(
          do.call("fsr",
            args = c(
              list(
                slotOptions = lavoptions,
                slotParTable = lavpartable,
                slotModel = lavmodel,
                # start        = FIT,
                data = DATA,
                cmd = "lavaan",
                fs.method = fs.method,
                fsr.method = fsr.method
              ),
              dotdotdot
            )
          ),
          silent = TRUE
        )
      } else if (cmd == "sam") {
        lavobject <- try(
          do.call("sam",
            args = c(
              list(
                model = model,
                data = DATA
              ),
              dotdotdot
            )
          ),
          silent = TRUE
        )
      } else {
        lavobject <- try(do.call(cmd,
          args = c(
              list(
                model = model,
                data = DATA
              ),
              dotdotdot
            )
          ),
          silent = TRUE
        )
        #lav_msg_stop(gettext("unknown cmd:"), cmd)
      }
    } # data.ok.flag

    RES <- list(
      ok = FALSE, timing = NULL, ParTable = NULL,
      Data = NULL, SampleStats = NULL, vcov = NULL,
      test = NULL, optim = NULL, implied = NULL,
      baseline = NULL, baseline.ok = FALSE, fun = NULL
    )

    if (data.ok.flag && inherits(lavobject, "lavaan") &&
      lavInspect(lavobject, "converged")) {
      RES$ok <- TRUE

      if (show.progress) {
        cat(
          "   OK -- niter = ",
          sprintf("%3d", lavInspect(lavobject, "iterations")),
          "\n"
        )
      }

      # extract slots from fit
      if ("timing" %in% store.slots) {
        RES$timing <- lavobject@timing
      }
      if ("partable" %in% store.slots) {
        RES$ParTable <- lavobject@ParTable
      }
      if ("data" %in% store.slots) {
        RES$Data <- lavobject@Data
      }
      if ("samplestats" %in% store.slots) {
        RES$SampleStats <- lavobject@SampleStats
      }
      if ("cache" %in% store.slots) {
        RES$Cache <- lavobject@Cache
      }
      if ("vcov" %in% store.slots) {
        RES$vcov <- lavobject@vcov
      }
      if ("test" %in% store.slots) {
        RES$test <- lavobject@test
      }
      if ("optim" %in% store.slots) {
        RES$optim <- lavobject@optim
      }
      if ("implied" %in% store.slots) {
        RES$implied <- lavobject@implied
      }
      if ("loglik" %in% store.slots) {
        RES$loglik <- lavobject@loglik
      }
      if ("h1" %in% store.slots) {
        RES$h1 <- lavobject@h1
      }
      if ("baseline" %in% store.slots) {
        RES$baseline <- lavobject@baseline
        if (length(lavobject@baseline) > 0L) {
          RES$baseline.ok <- TRUE
        }
      }

      # custom FUN
      if (!is.null(FUN)) {
        RES$fun <- FUN(lavobject)
      }
    } else { # failed!
      if (show.progress) {
        if (data.ok.flag) {
          if (inherits(lavobject, "lavaan")) {
            cat("   FAILED: no convergence\n")
          } else {
            cat("   FAILED: could not construct lavobject\n")
            print(lavobject)
          }
        } else {
          cat("   FAILED: nlev too low for some vars\n")
        }
      }
      if ("partable" %in% store.slots) {
        RES$ParTable <- lavpartable
        RES$ParTable$est <- RES$ParTable$start
        RES$ParTable$est[RES$ParTable$free > 0] <- as.numeric(NA)
        RES$ParTable$se <- numeric(length(lavpartable$lhs))
        RES$ParTable$se[RES$ParTable$free > 0] <- as.numeric(NA)
      }
      if (store.failed) {
        tmpfile <- tempfile(pattern = "lavaanListData")
        datfile <- paste0(tmpfile, ".csv")
        write.csv(DATA, file = datfile, row.names = FALSE)
        if (data.ok.flag) {
          # or only if lavobject is of class lavaan?
          objfile <- paste0(tmpfile, ".RData")
          save(lavobject, file = objfile)
        }
      }
    }

    RES
  }


  # the next 8 lines are borrowed from the boot package
  have_mc <- have_snow <- FALSE
  if (missing(parallel)) {
    parallel <- "no"
  }
  parallel <- match.arg(parallel)
  if (parallel != "no" && ncpus > 1L) {
    if (parallel == "multicore") {
      have_mc <- .Platform$OS.type != "windows"
    } else if (parallel == "snow") have_snow <- TRUE
    if (!have_mc && !have_snow) ncpus <- 1L
    loadNamespace("parallel") # before recording seed!
  }

  # iseed:
  # this follows a proposal of Shu Fai Cheung (see github issue #240)
  # - iseed is used for both serial and parallel
  # - if iseed is not set, iseed is generated + .Random.seed created/updated
  #     -> tmp.seed <- NA
  # - if iseed is set: don't touch .Random.seed (if it exists)
  #     -> tmp.seed <- .Random.seed (if it exists)
  #     -> tmp.seed <- NULL (if it does not exist)
  if (is.null(iseed)) {
    if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
      runif(1)
    }
    # identical(temp.seed, NA): Will not change .Random.seed in GlobalEnv
    temp.seed <- NA
    iseed <- runif(1, 0, 999999999)
  } else {
    if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
      temp.seed <-
        get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
    } else {
      # is.null(temp.seed): Will remove .Random.seed in GlobalEnv
      #                     if serial.
      #                     If parallel, .Random.seed will not be touched.
      temp.seed <- NULL
    }
  }
  if (!(ncpus > 1L && (have_mc || have_snow))) { # Only for serial
    set.seed(iseed)
  }

  # this is adapted from the boot function in package boot
  RES <- if (ncpus > 1L && (have_mc || have_snow)) {
    if (have_mc) {
      #RNGkind_old <- RNGkind() # store current kind
      RNGkind("L'Ecuyer-CMRG") # to allow for reproducible results
      set.seed(iseed)
      parallel::mclapply(seq_len(ndat), fn, mc.cores = ncpus)
    } else if (have_snow) {
      list(...) # evaluate any promises
      if (is.null(cl)) {
        cl <- parallel::makePSOCKcluster(rep("localhost", ncpus))
        # # No need for
        # if(RNGkind()[1L] == "L'Ecuyer-CMRG")
        # clusterSetRNGStream() always calls `RNGkind("L'Ecuyer-CMRG")`
        parallel::clusterSetRNGStream(cl, iseed = iseed)
        RES <- parallel::parLapply(cl, seq_len(ndat), fn)
        parallel::stopCluster(cl)
        RES
      } else {
        parallel::parLapply(cl, seq_len(ndat), fn)
      }
    }
  } else {
    lapply(seq_len(ndat), fn)
  }


  # restructure
  if ("baseline" %in% store.slots) {
    meta <- list(
      ndat = ndat, ok = sapply(RES, "[[", "ok"),
      baseline.ok = sapply(RES, "[[", "baseline.ok"),
      store.slots = store.slots
    )
  } else {
    meta <- list(
      ndat = ndat, ok = sapply(RES, "[[", "ok"),
      store.slots = store.slots
    )
  }

  # extract store.slots slots
  if ("timing" %in% store.slots) {
    timingList <- lapply(RES, "[[", "timing")
  }
  if ("partable" %in% store.slots) {
    ParTableList <- lapply(RES, "[[", "ParTable")
  }
  if ("data" %in% store.slots) {
    DataList <- lapply(RES, "[[", "Data")
  }
  if ("samplestats" %in% store.slots) {
    SampleStatsList <- lapply(RES, "[[", "SampleStats")
  }
  if ("cache" %in% store.slots) {
    CacheList <- lapply(RES, "[[", "Cache")
  }
  if ("vcov" %in% store.slots) {
    vcovList <- lapply(RES, "[[", "vcov")
  }
  if ("test" %in% store.slots) {
    testList <- lapply(RES, "[[", "test")
  }
  if ("optim" %in% store.slots) {
    optimList <- lapply(RES, "[[", "optim")
  }
  if ("implied" %in% store.slots) {
    impliedList <- lapply(RES, "[[", "implied")
  }
  if ("h1" %in% store.slots) {
    h1List <- lapply(RES, "[[", "h1")
  }
  if ("loglik" %in% store.slots) {
    loglikList <- lapply(RES, "[[", "loglik")
  }
  if ("baseline" %in% store.slots) {
    baselineList <- lapply(RES, "[[", "baseline")
  }
  if (!is.null(FUN)) {
    funList <- lapply(RES, "[[", "fun")
  }

  # create lavaanList object
  lavaanList <- new("lavaanList",
    version = packageDescription("lavaan", fields = "Version"),
    call = mc,
    Options = lavoptions,
    ParTable = lavpartable,
    pta = lavpta,
    Model = lavmodel,
    Data = FIT@Data,

    # meta
    meta = meta,

    # per dataset
    timingList = timingList,
    ParTableList = ParTableList,
    DataList = DataList,
    SampleStatsList = SampleStatsList,
    CacheList = CacheList,
    vcovList = vcovList,
    testList = testList,
    optimList = optimList,
    impliedList = impliedList,
    h1List = h1List,
    loglikList = loglikList,
    baselineList = baselineList,
    funList = funList,
    external = list()
  )

  # restore random seed
  if (!is.null(init.seed)) {
    assign(".Random.seed", init.seed, envir = .GlobalEnv)
  } else if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
    # initially there was no .Random.seed, but we created one along the way
    # clean up
    remove(".Random.seed", envir = .GlobalEnv)
  }
  # restore random generator method (if changed)
  RNGkind(RNGkind_old[1], RNGkind_old[2], RNGkind_old[3])

  lavaanList
}

semList <- function(model = NULL,
                    dataList = NULL,
                    dataFunction = NULL,
                    dataFunction.args = list(),
                    ndat = length(dataList),
                    ...,
                    store.slots = c("partable"),
                    FUN = NULL,
                    show.progress = FALSE,
                    store.failed = FALSE,
                    parallel = c("no", "multicore", "snow"),
                    ncpus = max(1L, parallel::detectCores() - 1L),
                    cl = NULL,
                    iseed = NULL) {
  mc <- match.call(expand.dots = TRUE)
  mc$cmd <- "sem"
  mc[[1L]] <- quote(lavaan::lavaanList)
  eval(mc, parent.frame())
}

cfaList <- function(model = NULL,
                    dataList = NULL,
                    dataFunction = NULL,
                    dataFunction.args = list(),
                    ndat = length(dataList),
                    ...,
                    store.slots = c("partable"),
                    FUN = NULL,
                    show.progress = FALSE,
                    store.failed = FALSE,
                    parallel = c("no", "multicore", "snow"),
                    ncpus = max(1L, parallel::detectCores() - 1L),
                    cl = NULL,
                    iseed = NULL) {
  mc <- match.call(expand.dots = TRUE)
  mc$cmd <- "cfa"
  mc[[1L]] <- quote(lavaan::lavaanList)
  eval(mc, parent.frame())
}

lav_lavaan_step08_start <- function(slotModel = NULL, # nolint
                                    lavoptions = NULL,
                                    lavpartable = NULL,
                                    lavsamplestats = NULL,
                                    lavh1 = NULL) {
  # # # # # # # # # # #
  # #  8. lavstart # #
  # # # # # # # # # # #

  # if slotModel is NULL
  #   if lavpartable$est not NULL and lavoptions$start == "default"
  #     if there are free variances with est==0 or there are NA's in est
  #       compute start column in lavpartable via lav_start
  #     else
  #       set start column in lavpartable equal to est column
  #   else
  #     compute start column via lav_start and
  #       check via lav_start_check_cov if demanded (lavoptions$check.start)

  samplestats.flag <- TRUE
  if (!is.null(lavoptions$samplestats) &&
      !lavoptions$samplestats) {
    samplestats.flag <- FALSE
  }

  if (is.null(slotModel)) {
    # check if we have provided a full parameter table as model = input
    if (!is.null(lavpartable$est) && is.character(lavoptions$start) &&
      lavoptions$start == "default") {
      if (lav_verbose()) {
        cat("lavstart           ...")
      }
      # check if all 'est' values look ok
      # this is not the case, eg, if partables have been merged eg, as
      # in semTools' auxiliary() function

      # check for zero free variances and NA values
      if (is.null(lavpartable$lower)) {
        zero.idx <- which(lavpartable$free > 0L &
          lavpartable$op == "~~" &
          lavpartable$lhs == lavpartable$rhs &
          lavpartable$est == 0)
      } else {
        # ignore zero variances on the boundary; new in 0.6-21
        zero.idx <- which(lavpartable$free > 0L &
          lavpartable$op == "~~" &
          lavpartable$lhs == lavpartable$rhs &
          lavpartable$est == 0 &
          lavpartable$lower != 0)
      }

      if (length(zero.idx) > 0L || any(is.na(lavpartable$est))) {
        lavpartable$start <- lav_start(
          start.method = lavoptions$start,
          lavpartable = lavpartable,
          lavsamplestats = lavsamplestats,
          model.type = lavoptions$model.type,
          reflect = FALSE,
		      samplestats.flag = samplestats.flag,
          # order.lv.by  = lavoptions$rotation.args$order.lv.by,
          order.lv.by = "none"
          )
      } else {
        lavpartable$start <- lavpartable$est
      }

      # check for exogenous parameters: if the dataset changed, we must
      # update them! (new in 0.6-16)
      # ... or not? (not compatible with how we bootstrap under fixed.x = T)
      # we really need to think about this more carefully...
      #
      # if (any(lavpartable$exo == 1L)) {
      #     # FIXME: there should be an easier way just to
      #     # (re)initialize the the exogenous part of the model
      #     tmp <- lav_start(start.method   = "lavaan", # not "simple"
      #                                                 # if fixed.x = TRUE
      #                    lavpartable    = lavpartable,
      #                    lavsamplestats = lavsamplestats,
      #                    lavh1          = lavh1,
      #                    model.type     = lavoptions$model.type,
      #                    reflect      = FALSE,
      #                    #order.lv.by  = lavoptions$rotation.args$order.lv.by,
      #                    order.lv.by  = "none",
      #                    debug          = lav_debug())
      #     exo.idx <- which(lavpartable$exo == 1L)
      #     lavpartable$start[exo.idx] <- tmp[exo.idx]
      # }

      if (lav_verbose()) {
        cat(" done.\n")
      }
    } else {
      if (lav_verbose()) {
        cat("lavstart           ...")
      }
      start.values <- lav_start(
        start.method = lavoptions$start,
        lavpartable = lavpartable,
        lavsamplestats = lavsamplestats,
        lavh1 = lavh1,
        model.type = lavoptions$model.type,
        reflect = FALSE,
        samplestats.flag = samplestats.flag,
        # order.lv.by  = lavoptions$rotation.args$order.lv.by,
        order.lv.by = "none"
      )

      # sanity check
      if (!is.null(lavoptions$check.start) && lavoptions$check.start) {
        start.values <- lav_start_check_cov(
          lavpartable = lavpartable,
          start = start.values
        )
      }

      lavpartable$start <- start.values
      if (lav_verbose()) {
        cat(" done.\n")
      }
    }
  }

  lavpartable
}

# methods
setMethod(
  "show", "lavaanList",
  function(object) {
    # check object
    object <- lav_object_check_version(object)
    # show only basic information
    lav_lavaanlist_short_summary(object, print = TRUE)
  }
)

lav_lavaanlist_short_summary <- function(object, print = TRUE) {
  txt <- sprintf(
    "lavaanList (%s) -- based on %d datasets (%d converged)\n",
    object@version,
    object@meta$ndat,
    sum(object@meta$ok)
  )

  if (print) {
    cat(txt)
  }

  invisible(txt)
}

setMethod(
  "summary", "lavaanList",
  function(object, header = TRUE,
           estimates = TRUE,
           print = TRUE,
           nd = 3L,
           simulate.args = list(est.bias = TRUE,
                                se.bias  = TRUE,
                                prop.sig = TRUE,
                                coverage = TRUE,
                                level    = 0.95,
                                trim     = 0),
           ...) {
    dotdotdot <- list(...)
    if (length(dotdotdot) > 0L) {
      for (j in seq_along(dotdotdot)) {
        lav_msg_warn(gettextf(
          "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
          sQuote("summary"))
        )
      }
    }
    lav_lavaanlist_summary(object,
      header = header, estimates = estimates,
      print = print, nd = nd, simulate.args = simulate.args
    )
  }
)

lav_lavaanlist_summary <- function(object,
                                   header = TRUE,
                                   estimates = TRUE,
                                   simulate.args = list(est.bias = TRUE,
                                                        se.bias  = TRUE,
                                                        prop.sig = TRUE,
                                                        coverage = TRUE,
                                                        level    = 0.95,
                                                        trim     = 0),
                                   zstat = TRUE,
                                   pvalue = TRUE,
                                   print = TRUE,
                                   nd = 3L) {
  # check object
  object <- lav_object_check_version(object)

  out <- list()

  if (header) {
    out$header <- lav_lavaanlist_short_summary(object, print = print)

    # if(print) {
    #    # show only basic information
    #    lav_lavaanlist_short_summary(object)
    # }
  }
  if (print) {
    output <- "text"
  } else {
    output <- "data.frame"
  }

  if (estimates && "partable" %in% object@meta$store.slots) {
    pe <- lavParameterEstimates(object,
      se = FALSE,
      remove.system.eq = FALSE, remove.eq = FALSE,
      remove.ineq = FALSE, remove.def = FALSE,
      remove.nonfree = FALSE, remove.unused = FALSE,
      remove.step1 = FALSE, # in case we used sam()
      # zstat = FALSE, pvalue = FALSE, ci = FALSE,
      standardized = FALSE,
      output = output
    )

    # scenario 1: simulation
    if (!is.null(object@meta$lavSimulate)) {

      # default behavior
      sim.args <- list(est.bias = TRUE,
                       se.bias  = TRUE,
                       prop.sig = TRUE,
                       coverage = TRUE,
                       level    = 0.95,
                       trim     = 0)
      sim.args <- modifyList(sim.args, simulate.args)
      #if (!sim.args$est.bias) {
      #  sim.args$se.bias <- FALSE
      #}
      if (!sim.args$se.bias) {
        sim.args$prop.sig <- FALSE
      }

      pe$est.true <- object@meta$est.true
      nel <- length(pe$est.true)

      # always compute EST
      EST <- lav_lavaanlist_partable(object, what = "est", type = "all")

      # sometimes compute SE
      if (sim.args$se.bias || sim.args$prop.sig || sim.args$coverage) {
        SE <- lav_lavaanlist_partable(object, what = "se", type = "all")
      }

      # est.bias?
      if (sim.args$est.bias) {
        AVE <- apply(EST, 1L, mean, na.rm = TRUE, trim = sim.args$trim)

        # remove things like equality constraints
        if (length(AVE) > nel) {
          AVE <- AVE[seq_len(nel)]
        }
        AVE[!is.finite(AVE)] <- as.numeric(NA)
        pe$est.ave <- AVE
        pe$est.bias <- pe$est.ave - pe$est.true

        # FIXME: should we also add bias^2 and MSE?
        # and what about relative bias?
      }


      # SE?
      if (sim.args$se.bias) {
        SE.OBS <- apply(EST, 1L, lav_sample_trimmed_sd, na.rm = TRUE,
                        trim = sim.args$trim)
        if (length(SE.OBS) > nel) {
          SE.OBS <- SE.OBS[seq_len(nel)]
        }
        SE.OBS[!is.finite(SE.OBS)] <- as.numeric(NA)
        pe$se.obs <- SE.OBS
        SE.AVE <- apply(SE, 1L, mean, na.rm = TRUE, trim = sim.args$trim)
        if (length(SE.AVE) > nel) {
          SE.AVE <- SE.AVE[seq_len(nel)]
        }
        SE.AVE[!is.finite(SE.AVE)] <- as.numeric(NA)
        pe$se.ave <- SE.AVE
        se.obs <- SE.OBS
        se.obs[se.obs < .Machine$double.eps^(1/3)] <- as.numeric(NA)
        pe$se.bias <- pe$se.ave / se.obs # use ratio!
        pe$se.bias[!is.finite(pe$se.bias)] <- as.numeric(NA)
      }

      if (sim.args$prop.sig) {
        SE[SE < sqrt(.Machine$double.eps)] <- as.numeric(NA)
        WALD <- EST/SE
        wald <- apply(WALD, 1L, mean, na.rm = TRUE,
                      trim = sim.args$trim)
        wald[!is.finite(wald)] <- as.numeric(NA)
        pe$wald <- wald
        PVAL <- 2 * (1 - pnorm(abs(WALD)))
        propsig <- apply(PVAL, 1L, function(x) {
                        x.ok <- x[is.finite(x)]
                        nx <- length(x.ok)
                        sum(x.ok < (1 - sim.args$level))/nx
                       })
        propsig[!is.finite(propsig)] <- as.numeric(NA)
        pe$prop.sig <- propsig
      }

      if (sim.args$coverage) {
        # next three lines based on confint.lm
        a <- (1 - sim.args$level) / 2
        a <- c(a, 1 - a)
        fac <- qnorm(a)
        CI.LOWER <- EST + fac[1]*SE
        CI.UPPER <- EST + fac[2]*SE
        ci.lower <- apply(CI.LOWER, 1L, mean, na.rm = TRUE,
                          trim = sim.args$trim)
        ci.upper <- apply(CI.UPPER, 1L, mean, na.rm = TRUE,
                          trim = sim.args$trim)
        ci.lower[!is.finite(ci.lower)] <- as.numeric(NA)
        ci.upper[!is.finite(ci.upper)] <- as.numeric(NA)
        pe$ci.lower <- ci.lower
        pe$ci.upper <- ci.upper
        # columnwise comparison
        inside.flag <- (CI.LOWER <= pe$est.true) & (CI.UPPER >= pe$est.true)
        coverage <- apply(inside.flag, 1L, mean, na.rm = TRUE)
        coverage[!is.finite(coverage)] <- as.numeric(NA)
        pe$coverage <- coverage
      }

      # if sam(), should we keep or remove the step1 values?
      # keep them for now

      # scenario 2: bootstrap
    } else if (!is.null(object@meta$lavBootstrap)) {
      # print the average value for est
      EST <- lav_lavaanlist_partable(object, what = "est", type = "all")
      pe$est.ave <- rowMeans(EST, na.rm = TRUE)

      # scenario 3: multiple imputation
    } else if (!is.null(object@meta$lavMultipleImputation)) {
      # pool est: take the mean
      EST <- lav_lavaanlist_partable(object, what = "est", type = "all")
      m <- NCOL(EST)
      pe$est <- rowMeans(EST, na.rm = TRUE)

      # pool se

      # between-imputation variance
      # B.var <- apply(EST, 1L, var)
      est1 <- rowMeans(EST, na.rm = TRUE)
      est2 <- rowMeans(EST^2, na.rm = TRUE)
      B.var <- (est2 - est1 * est1) * m / (m - 1)

      # within-imputation variance
      SE <- lav_lavaanlist_partable(object, what = "se", type = "all")
      W.var <- rowMeans(SE^2, na.rm = TRUE)

      # total variance: T.var = W.var + B.var + B.var/m
      pe$se <- sqrt(W.var + B.var + (B.var / m))

      tmp.se <- ifelse(pe$se == 0.0, NA, pe$se)
      if (zstat) {
        pe$z <- pe$est / tmp.se
        if (pvalue) {
          pe$pvalue <- 2 * (1 - pnorm(abs(pe$z)))
        }
      }

      # scenario 4: multiple groups/sets
    } else if (!is.null(object@meta$lavMultipleGroups)) {
      # show individual estimates, for each group
      EST <- lav_lavaanlist_partable(object, what = "est", type = "all")
      EST <- as.list(as.data.frame(EST))
      ngroups <- length(EST)
      names(EST) <- object@meta$group.label
      ATTR <- attributes(pe)
      NAMES <- c(names(pe), names(EST))
      pe <- c(pe, EST)
      attributes(pe) <- ATTR
      names(pe) <- NAMES
    }

    # scenario 5: just a bunch of fits, using different datasets
    else {
      # print the average value for est
      EST <- lav_lavaanlist_partable(object, what = "est", type = "all")
      pe$est.ave <- rowMeans(EST, na.rm = TRUE)

      # more?
    }

    # remove ==,<,>
    rm.idx <- which(pe$op %in% c("==", "<", ">"))
    if (length(rm.idx) > 0L) {
      pe <- pe[-rm.idx, ]
    }

    out$pe <- pe

    if (print) {
      # print pe?
      print(pe, nd = nd)
    }
  } else {
    cat("available slots (per dataset) are:\n")
    print(object@meta$store.slots)
  }

  invisible(out)
}

setMethod(
  "coef", "lavaanList",
  function(object, type = "free", labels = TRUE, ...) {
    # check object
    object <- lav_object_check_version(object)
    dotdotdot <- list(...)
    if (length(dotdotdot) > 0L) {
      for (j in seq_along(dotdotdot)) {
        lav_msg_warn(gettextf(
          "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
          sQuote("coef"))
        )
      }
    }
    lav_lavaanlist_partable(
      object = object, what = "est", type = type,
      labels = labels
    )
  }
)

lav_lavaanlist_partable <- function(object, what = "est",
                                    type = "free", labels = TRUE) {
  # check object
  object <- lav_object_check_version(object)
  if ("partable" %in% object@meta$store.slots) {
    if (what %in% names(object@ParTableList[[1]])) {
      OUT <- sapply(object@ParTableList, "[[", what)
    } else {
      lav_msg_stop(gettextf(
        "column `%s' not found in the first element of the ParTableList slot.",
        what))
    }
  } else {
    lav_msg_stop(gettext("no ParTable slot stored in lavaanList object"))
  }

  if (type == "user" || type == "all") {
    type <- "user"
    idx <- 1:length(object@ParTable$lhs)
  } else if (type == "free") {
    idx <- which(object@ParTable$free > 0L & !duplicated(object@ParTable$free))
  } else {
    lav_msg_stop(gettext("argument `type' must be one of free or user"))
  }

  OUT <- OUT[idx, , drop = FALSE]

  if (labels) {
    rownames(OUT) <- lav_partable_labels(object@ParTable, type = type)
  }

  OUT
}

# compute 'Omega' == A1^{-1} B1 A1^{-1}
# where A1 is the expected/observed information matrix of the unrestricted (h1)
# model, and B1 is the first-order information matrix of the unrestricted (h1)
# model
#
# but the exact result will depend on the options:
# for 'A':
# - omega.information ("expected" or "observed")
# - omega.h1.information ("structured" or "unstructured")
# for 'B':
# - omega.information.meat ("first-order")
# - omega.h1.information.meat ("structured" or "unstructured")
#
# special case: if data is complete, A is expected/unstructured, and B is
# unstructured, we get (sample-based) 'Gamma'
#
# YR 28 Oct 2020

lav_model_h1_omega <- function(lavobject = NULL,
                               lavmodel = NULL,
                               lavsamplestats = NULL,
                               lavdata = NULL,
                               lavimplied = NULL,
                               lavh1 = NULL,
                               lavcache = NULL,
                               lavoptions = NULL) {
  if (!is.null(lavobject) && inherits(lavobject, "lavaan")) {
    lavmodel <- lavobject@Model
    lavsamplestats <- lavobject@SampleStats
    lavdata <- lavobject@Data
    lavimplied <- lavobject@implied
    lavh1 <- lavobject@h1
    lavcache <- lavobject@Cache
    lavoptions <- lavobject@Options
  }

  # sanity check
  if (length(lavh1) == 0L) {
    lavh1 <- lav_h1_implied_logl(
      lavdata = lavdata,
      lavsamplestats = lavsamplestats,
      lavoptions = lavoptions
    )
  }
  if (length(lavimplied) == 0L) {
    lavimplied <- lav_model_implied(lavmodel = lavmodel)
  }

  # set options for A
  A1.options <- lavoptions
  A1.options$information <- lavoptions$omega.information
  A1.options$h1.information <- lavoptions$omega.h1.information

  B1.options <- lavoptions
  B1.options$information <- lavoptions$omega.information.meat # unused
  B1.options$h1.information <- lavoptions$omega.h1.information.meat

  # information
  information <- lavoptions$omega.information

  # compute A1 (per group)
  if (information == "observed") {
    A1 <- lav_model_h1_information_observed(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavimplied = lavimplied, lavh1 = lavh1,
      lavcache = lavcache, lavoptions = A1.options
    )
  } else if (information == "expected") {
    A1 <- lav_model_h1_information_expected(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavimplied = lavimplied, lavh1 = lavh1,
      lavcache = lavcache, lavoptions = A1.options
    )
  } else if (information == "first.order") { # not needed?
    A1 <- lav_model_h1_information_firstorder(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavdata = lavdata,
      lavimplied = lavimplied, lavh1 = lavh1,
      lavcache = lavcache, lavoptions = A1.options
    )
  }

  # compute B1 (per group)
  B1 <- lav_model_h1_information_firstorder(
    lavmodel = lavmodel,
    lavsamplestats = lavsamplestats, lavdata = lavdata,
    lavimplied = lavimplied, lavh1 = lavh1,
    lavcache = lavcache, lavoptions = B1.options
  )

  # return Omega per group
  Omega <- vector("list", length = lavdata@ngroups)
  trace.h1 <- numeric(lavdata@ngroups)
  h1.ndat <- numeric(lavdata@ngroups)
  for (g in seq_len(lavdata@ngroups)) {
    A1.g <- A1[[g]]
    B1.g <- B1[[g]]

    # mask independent 'fixed-x' variables
    zero.idx <- which(diag(A1.g) == 0)
    if (length(zero.idx) > 0L) {
      A1.inv <- matrix(0, nrow(A1.g), ncol(A1.g))
      a1 <- A1.g[-zero.idx, -zero.idx, drop = FALSE]
      a1.inv <- solve(a1)
      A1.inv[-zero.idx, -zero.idx] <- a1.inv
    } else {
      A1.inv <- solve(A1.g)
    }
    trace.h1[g] <- sum(B1.g * t(A1.inv))
    h1.ndat[g] <- ncol(A1.g) - length(zero.idx)

    Omega[[g]] <- A1.inv %*% B1.g %*% A1.inv
  }

  # store trace.h1 as an attribute (to be used in yuan-bentler)
  attr(Omega, "trace.h1") <- trace.h1
  attr(Omega, "h1.ndat") <- h1.ndat
  attr(Omega, "A.information") <- paste(A1.options$information,
    A1.options$h1.information,
    sep = "."
  )
  attr(Omega, "B.information") <- paste(B1.options$information,
    B1.options$h1.information,
    sep = "."
  )

  Omega
}

# export to Mplus syntax

lav_export_mplus <- function(lav, group.label = NULL) {
  lav <- lav_export_check(lav)
  header <- "  ! this model syntax is autogenerated by lav_export\n"
  footer <- "\n"

  lav <- as.data.frame(lav, stringsAsFactors = FALSE)
  ngroups <- lav_partable_ngroups(lav)

  lav_one_group <- function(lav) {
    # mplus does not like variable names with a 'dot'
    # replace them by an underscore '_'
    lav$lhs <- gsub("\\.", "_", lav$lhs)
    lav$rhs <- gsub("\\.", "_", lav$rhs)

    # remove contraints (:=, <, >, ==) here
    con.idx <- which(lav$op %in% c(":=", "<", ">", "=="))
    if (length(con.idx) > 0L) {
      lav <- lav[-con.idx, ]
    }

    # remove exogenous variances/covariances/intercepts...
    exo.idx <- which(lav$exo == 1L & lav$op %in% c("~~", "~1"))
    if (length(exo.idx)) {
      lav <- lav[-exo.idx, ]
    }

    # remove intercepts for categorical variables
    ord.names <- unique(lav$lhs[lav$op == "|"])
    ord.int.idx <- which(lav$op == "~1" & lav$lhs %in% ord.names)
    if (length(ord.int.idx)) {
      lav <- lav[-ord.int.idx, ]
    }

    # end of line
    lav$eol <- rep(";", length(lav$lhs))
    lav$ustart <- ifelse(is.na(lav$ustart), "", lav$ustart)
    lav$rhs2 <- ifelse(lav$free == 0L,
      paste("@", lav$ustart, sep = ""),
      paste("*", lav$ustart, sep = "")
    )
    lav$plabel <- gsub("\\.", "", lav$plabel)
    LABEL <- ifelse(lav$label == "", lav$plabel, lav$label)
    lav$plabel <- ifelse(LABEL == "", LABEL,
      paste(" (", LABEL, ")", sep = "")
    )

    # remove variances for ordered variables
    ov.names.ord <- lav_partable_vnames(lav, type = "ov.ord")
    ord.idx <- which(lav$lhs %in% ov.names.ord &
      lav$op == "~~" &
      lav$free == 0L &
      lav$lhs == lav$rhs)
    lav$lhs[ord.idx] <- paste("! ", lav$lhs[ord.idx], sep = "")
    lav$op[ord.idx] <- ""
    lav$rhs[ord.idx] <- ""

    # variances
    var.idx <- which(lav$op == "~~" & lav$rhs == lav$lhs)
    lav$op[var.idx] <- ""
    lav$rhs[var.idx] <- ""

    # scaling factors
    scal.idx <- which(lav$op == "~*~")
    lav$op[scal.idx] <- ""
    lav$rhs2[scal.idx] <- paste(lav$rhs2[scal.idx], "}", sep = "")
    lav$lhs[scal.idx] <- "{"

    # intercepts - excluding categorical observed
    int.idx <- which(lav$op == "~1")
    lav$op[int.idx] <- ""
    lav$rhs2[int.idx] <- paste(lav$rhs2[int.idx], "]", sep = "")
    lav$lhs[int.idx] <- paste("[", lav$lhs[int.idx], sep = "")

    # thresholds
    th.idx <- which(lav$op == "|")
    lav$op[th.idx] <- "$"
    lav$rhs[th.idx] <- gsub("t", "", x = lav$rhs[th.idx])
    lav$rhs2[th.idx] <- paste(lav$rhs2[th.idx], "]", sep = "")
    lav$lhs[th.idx] <- paste("[", lav$lhs[th.idx], sep = "")

    # replace binary operators
    lav$op <- ifelse(lav$op == "=~", " BY ", lav$op)
    lav$op <- ifelse(lav$op == "~", " ON ", lav$op)
    lav$op <- ifelse(lav$op == "~~", " WITH ", lav$op)


    lav2 <- paste(lav$lhs, lav$op, lav$rhs, lav$rhs2,
      lav$plabel, lav$eol,
      sep = ""
    )

    body <- paste(" ", lav2, collapse = "\n")

    body
  }

  if (ngroups == 1L) {
    body <- lav_one_group(lav)
  } else {
    group.values <- lav_partable_group_values(lav)
    # group 1
    body <- lav_one_group(lav[lav$group == group.values[1], ])

    if (is.null(group.label) || length(group.label) == 0L) {
      group.label <- paste(1:ngroups)
    }

    for (g in 2:ngroups) {
      body <- paste(body,
        paste("\nMODEL ", group.label[g], ":\n", sep = ""),
        lav_one_group(lav[lav$group == group.values[g], ]),
        sep = ""
      )
    }
  }

  # constraints go to a 'MODEL CONSTRAINTS' block
  con.idx <- which(lav$op %in% c(":=", "<", ">", "=="))
  if (length(con.idx) > 0L) {
    ### FIXME: we need to convert the operator
    ### eg b^2 --> b**2, others??
    lav$lhs[con.idx] <- gsub("\\^", "**", lav$lhs[con.idx])
    lav$rhs[con.idx] <- gsub("\\^", "**", lav$rhs[con.idx])

    constraints <- "\nMODEL CONSTRAINT:\n"
    # define 'new' variables
    def.idx <- which(lav$op == ":=")
    if (length(def.idx) > 0L) {
      def <- paste(lav$lhs[def.idx], collapse = " ")
      constraints <- paste(constraints, "NEW (", def, ");")
      lav$op[def.idx] <- "="
    }
    # replace '==' by '='
    eq.idx <- which(lav$op == "==")
    if (length(eq.idx) > 0L) {
      lav$op[eq.idx] <- "="
    }
    con <- paste(gsub("\\.", "", lav$lhs[con.idx]), " ",
      lav$op[con.idx], " ",
      gsub("\\.", "", lav$rhs[con.idx]), ";",
      sep = ""
    )
    con2 <- paste("  ", con, collapse = "\n")
    constraints <- paste(constraints, con2, sep = "\n")
  } else {
    constraints <- ""
  }

  out <- paste(header, body, constraints, footer, sep = "")
  class(out) <- c("lavaan.character", "character")
  out
}


# helper functions
lav_mplus_estimator <- function(object) {
  estimator <- object@Options$estimator
  if (estimator == "DWLS") {
    estimator <- "WLS"
  }

  # only 1 argument for 'test' is allowed
  if (length(object@Options$test) > 1L) {
    standard.idx <- which(object@Options$test == "standard")
    if (length(standard.idx) > 1L) {
      object@Options$test <- object@Options$test[-standard.idx]
    }
    if (length(object@Options$test) > 1L) {
      lav_msg_warn(gettext("only first (non-standard) test will be used"))
      object@Options$test <- object@Options$test[1]
    }
  }

  if (estimator == "ML") {
    if (object@Options$test %in% c("yuan.bentler", "yuan.bentler.mplus")) {
      estimator <- "MLR"
    } else if (object@Options$test == "satorra.bentler") {
      estimator <- "MLM"
    } else if (object@Options$test == "scaled.shifted") {
      estimator <- "MLMV"
    } else if (object@Options$se == "first.order") {
      estimator <- "MLF"
    }
  } else if (estimator %in% c("ULS", "WLS")) {
    if (object@Options$test == "satorra.bentler") {
      estimator <- paste(estimator, "M", sep = "")
    } else if (object@Options$test == "scaled.shifted") {
      estimator <- paste(estimator, "MV", sep = "")
    }
  } else if (estimator == "MML") {
    estimator <- "ML"
  }

  estimator
}

lav_mplus_header <- function(data.file = NULL, group.label = "", ov.names = "",
                             listwise = FALSE,
                             ov.ord.names = "", estimator = "ML",
                             meanstructure = FALSE,
                             weight.name = character(0L),
                             information = "observed",
                             data.type = "full", nobs = NULL) {
  # replace '.' by '_' in all variable names
  ov.names <- gsub("\\.", "_", ov.names)
  ov.ord.names <- gsub("\\.", "_", ov.ord.names)

  ### FIXME!!
  ### this is old code from lavaan 0.3-1
  ### surely, this can be done better...

  # TITLE command
  c.TITLE <- "TITLE:\n"
  c.TITLE <- paste(
    c.TITLE,
    "  [This syntax is autogenerated by lav_export]\n"
  )

  # DATA command
  c.DATA <- "DATA:\n"
  ngroups <- length(data.file)
  if (ngroups == 1L) {
    c.DATA <- paste(c.DATA,
      "  file is ", data.file, ";\n",
      sep = ""
    )
  } else {
    for (g in 1:ngroups) {
      c.DATA <- paste(c.DATA,
        "  file (", group.label[g], ") is ",
        data.file[g], ";\n",
        sep = ""
      )
    }
  }
  if (data.type == "full") {
    c.DATA <- paste(c.DATA, "  type is individual;\n", sep = "")
    if (listwise) {
      c.DATA <- paste(c.DATA, "  listwise = on;\n", sep = "")
    }
  } else if (data.type == "moment") {
    c.DATA <- paste(c.DATA, "  type is fullcov;\n", sep = "")
    c.DATA <- paste(c.DATA, "  nobservations are ", nobs, ";\n", sep = "")
  } else {
    lav_msg_stop(gettext("data.type must be full or moment"))
  }

  # VARIABLE command
  c.VARIABLE <- "VARIABLE:\n"
  c.VARIABLE <- paste(c.VARIABLE, "  names are", sep = "")
  nvar <- length(ov.names)
  tmp <- 0
  for (i in 1:nvar) {
    if (tmp %% 6 == 0) {
      c.VARIABLE <- paste(c.VARIABLE, "\n    ", sep = "")
    }
    c.VARIABLE <- paste(c.VARIABLE, ov.names[i], sep = " ")
    tmp <- tmp + 1
  }
  c.VARIABLE <- paste(c.VARIABLE, ";\n", sep = "")
  # missing
  if (data.type == "full") {
    c.VARIABLE <- paste(c.VARIABLE,
      "  missing are all (-999999);\n",
      sep = ""
    )
  }
  # categorical?
  if (length(ov.ord.names)) {
    c.VARIABLE <- paste(c.VARIABLE, "  categorical are", sep = "")
    nvar <- length(ov.ord.names)
    tmp <- 0
    for (i in 1:nvar) {
      if (tmp %% 6 == 0) {
        c.VARIABLE <- paste(c.VARIABLE, "\n    ", sep = "")
      }
      c.VARIABLE <- paste(c.VARIABLE, ov.ord.names[i])
      tmp <- tmp + 1
    }
    c.VARIABLE <- paste(c.VARIABLE, ";\n", sep = "")
  }
  # weight variable?
  if (length(weight.name) > 0L) {
    c.VARIABLE <- paste(c.VARIABLE,
      "  weight = ", weight.name, ";\n",
      sep = ""
    )
  }

  # ANALYSIS command
  c.ANALYSIS <- paste("ANALYSIS:\n  type = general;\n", sep = "")
  c.ANALYSIS <- paste(c.ANALYSIS, "  estimator = ", toupper(estimator),
    ";\n",
    sep = ""
  )
  if (toupper(estimator) %in% c("ML", "MLR")) {
    c.ANALYSIS <- paste(c.ANALYSIS, "  information = ", information[1],
      ";\n",
      sep = ""
    )
  }
  if (!meanstructure) {
    c.ANALYSIS <- paste(c.ANALYSIS, "  model = nomeanstructure;\n",
      sep = ""
    )
  }

  # MODEL command
  c.MODEL <- paste("MODEL:\n")

  # assemble pre-model header
  out <- paste(c.TITLE, c.DATA, c.VARIABLE, c.ANALYSIS, c.MODEL, sep = "")

  out
}

lav_lavaan_step06_h1 <- function(sloth1 = NULL,
                                 lavoptions = NULL,
                                 lavsamplestats = NULL,
                                 lavdata = NULL,
                                 lavpartable = NULL) {
  # # # # # # # # #
  # #  6. lavh1 # #
  # # # # # # # # #

  # if sloth1 not NULL
  #   copy to lavh1
  # else
  #   if lavoptions$h1 TRUE
  #     if length(lavsamplestats$ntotal) > 0
  #       compute lavh1 via lav_h1_implied_logl
  #   else
  #     check lavoptions$h1 is logical, if not *** error ***

  if (!is.null(sloth1)) {
    lavh1 <- sloth1
  } else {
    lavh1 <- list()
    if (is.logical(lavoptions$h1) && lavoptions$h1) {
      if (length(lavsamplestats@ntotal) > 0L ||
	      (!is.null(lavoptions$samplestats) && !lavoptions$samplestats)) {
		  # lavsamplestats filled in
        if (lav_verbose()) {
          cat("lavh1              ... start:\n")
        }

        # implied h1 statistics and logl (if available)
        lavh1 <- lav_h1_implied_logl(
          lavdata = lavdata,
          lavsamplestats = lavsamplestats,
          lavpartable = lavpartable,
          lavoptions = lavoptions
        )
        if (lav_debug()) {
          print(lavh1)
        }
        if (lav_verbose()) {
          cat("lavh1              ... done.\n")
        }
      } else {
        # do nothing for now
      }
    } else {
      if (!is.logical(lavoptions$h1)) {
        lav_msg_stop(gettext("argument `h1' must be logical (for now)"))
      }
      # TODO: allow h1 to be either a model syntax, a parameter table,
      # or a fitted lavaan object
    }
  }

  lavh1
}

# STEP 0: process full model, without fitting
lav_sam_step0 <- function(cmd = "sem", model = NULL, data = NULL,
                          se = "twostep", sam.method = "local",
                          dotdotdot = NULL) {

  # create dotdotdot0 for dummy fit
  dotdotdot0 <- dotdotdot

  # parse model, so we can inspect a few features
  flat.model <- lavParseModelString(model)

  # remove do.fit option if present
  dotdotdot0$do.fit <- NULL

  if (sam.method %in% c("local", "fsr", "cfsr")) {
    dotdotdot0$sample.icov <- FALSE # if N < nvar
  }
  dotdotdot0$se                   <- "none"
  dotdotdot0$test                 <- "none"
  dotdotdot0$verbose              <- FALSE # no output for this 'dummy' FIT
  # if (sam.method != "global") {
  #   dotdotdot0$conditional.x        <- FALSE
  # }
  #dotdotdot0$fixed.x              <- TRUE
  dotdotdot0$ceq.simple           <- TRUE # if not the default yet
  dotdotdot0$check.lv.interaction <- FALSE # we allow for it
  # dotdotdot0$cat.wls.w            <- FALSE # no weight matrix if categorical
  # note: this breaks the computation of twostep standard errors...
  if (se %in% c("local", "ij", "twostep.robust")) {
    dotdotdot0$sample.icov <- TRUE
    dotdotdot0$NACOV <- TRUE
    #dotdotdot0$gamma.unbiased <- TRUE
    dotdotdot0$fixed.x <- FALSE
    dotdotdot0$ov.order <- "force.model" # avoid data ordering...
  }

  # any lv interaction terms?
  if (length(lav_object_vnames(flat.model, "lv.interaction")) > 0L) {
    dotdotdot0$meanstructure   <- TRUE
    #dotdotdot0$marker.int.zero <- FALSE # or not?
  }

  # initial processing of the model, no fitting
  FIT <- do.call(cmd,
    args = c(list(
      model  = flat.model,
      data   = data,
      do.fit = FALSE
    ), dotdotdot0)
  )

  # restore options

  # do.fit
  FIT@Options$do.fit <- TRUE
  # FIT@Options$cat.wls.w <- TRUE

  # sample.icov
  if (sam.method %in% c("local", "fsr", "cfsr")) {
    FIT@Options$sample.icov <- TRUE
  }

  # se
  if (FIT@Model@categorical && se == "twostep") {
    # FIXME!
    # should do this for global too, but we need the 'P' matrix, which
    # we only have for local (for now)
    if (sam.method == "local") {
      se <- "twostep.robust"
    }
  }
  FIT@Options$se <- se

  # test
  if (!is.null(dotdotdot$test)) {
    FIT@Options$test <- dotdotdot$test
  } else {
    FIT@Options$test <- "standard"
  }

  # adjust parameter table:
  PT <- FIT@ParTable

  # check parameter table
  PT$est <- PT$se <- NULL
  # est equals ustart by default (except exo values)
  PT$est <- PT$ustart
  if (any(PT$exo > 0L)) {
    PT$est[PT$exo > 0L] <- PT$start[PT$exo > 0L]
  }

  # clear se values (needed here?) only for global approach to compute SE
  PT$se <- rep(as.numeric(NA), length(PT$lhs))
  PT$se[PT$free == 0L & !is.na(PT$ustart)] <- 0.0

  FIT@ParTable <- PT


  FIT
}

# handle bare-minimum partables
# add some additional columns
lav_partable_complete <- function(partable = NULL, start = TRUE) { # nolint
  # check if we hava a data.frame
  # if so, check for columns that are 'factor' and convert them to 'character'
  ovda <- attr(partable, "ovda")
  if (is.data.frame(partable)) {
    fac.idx <- sapply(partable, is.factor)
    partable[fac.idx] <- lapply(partable[fac.idx], as.character)
  }

  # check if we have lhs, op, rhs
  stopifnot(!is.null(partable$lhs),
    !is.null(partable$op),
    !is.null(partable$rhs))

  # number of elements
  tmp.n <- length(partable$lhs)
  if (!is.data.frame(partable)) {
    # check for equal column length
    nel <- sapply(partable, length)
    short.idx <- which(nel < tmp.n)
    long.idx <- which(nel > tmp.n)
    if (length(long.idx) > 0L) {
      lav_msg_warn(gettext("partable columns have unequal length"))
    }
    if (length(short.idx) > 0L) {
      # try to extend them in a 'natural' way
      for (i in short.idx) {
        too.short <- tmp.n - nel[i]
        if (is.integer(partable[[i]])) {
          partable[[i]] <- c(partable[[i]],
            integer(too.short))
        } else if (is.numeric(partable[[i]])) {
          partable[[i]] <- c(partable[[i]],
            numeric(too.short))
        } else {
          partable[[i]] <- c(partable[[i]],
            character(too.short))
        }
      }
    }
  }

  # create new id column
  # if(is.null(partable$id)) {
  partable$id <- seq_len(tmp.n)
  # }

  # add user column
  if (is.null(partable$user)) {
    partable$user <- rep(1L, tmp.n)
  } else {
    partable$user <- as.integer(partable$user)
  }

  # add block column
  if (is.null(partable$block)) {
    partable$block <- rep(1L, tmp.n)
  } else {
    partable$block <- as.integer(partable$block)
  }

  # add group column
  if (is.null(partable$group)) {
    partable$group <- rep(1L, tmp.n)
  } else {
    # partable$group <- as.integer(partable$group) # maybe labels?
  }

  # add free column
  if (is.null(partable$free)) {
    partable$free <- seq_len(tmp.n)
    # 0.6-11: check for simple equality constraints
    #         note: this is perhaps only a subset (eg SAM!) of a larger
    #         table, and we have to renumber the 'free' column
  } else if (is.integer(partable$free) &&
    any(partable$free > 0L)   &&
    !any(partable$op == "==") &&
    !is.null(partable$label)  &&
    !is.null(partable$plabel) &&
    any(duplicated(partable$free[partable$free > 0L]))) {
    dup.idx <- which(partable$free > 0L & duplicated(partable$free))
    all.idx <- which(partable$free %in% unique(partable$free[dup.idx]))
    eq.labels <- unique(partable$free[all.idx])
    eq.id <- integer(length(partable$lhs))
    eq.id[all.idx] <- partable$free[all.idx]
    partable$free[dup.idx] <- 0L
    idx.free <- which(partable$free > 0L)
    partable$free <- rep(0L, tmp.n)
    partable$free[idx.free] <- seq_along(idx.free)
    for (eq.label in eq.labels) {
      all.idx <- which(eq.id == eq.label)
      ref.idx <- all.idx[1L]
      other.idx <- all.idx[-1L]
      partable$free[other.idx] <- partable$free[ref.idx]
    }
  } else {
    # treat non-zero as 'free'
    free.idx <- which(as.logical(partable$free))
    partable$free <- rep(0L, tmp.n)
    if (length(free.idx) > 0L) {
      partable$free[free.idx] <- seq_len(length(free.idx))
    }
  }

  # add ustart column
  if (is.null(partable$ustart)) {
    # do we have something else? start? est?
    if (!is.null(partable$start)) {
      partable$ustart <- as.numeric(partable$start)
    } else if (!is.null(partable$est)) {
      partable$ustart <- as.numeric(partable$est)
    } else {
      partable$ustart <- rep(as.numeric(NA), tmp.n)
      non.free <- which(!partable$free)
      if (length(non.free)) {
        partable$ustart[non.free] <- 0
      }
    }
  } else {
    partable$ustart <- as.numeric(partable$ustart)
  }

  # add exo column
  if (is.null(partable$exo)) {
    partable$exo <- rep(0, tmp.n)
  } else {
    partable$exo <- as.integer(partable$exo)
  }

  # add label column
  if (is.null(partable$label)) {
    partable$label <- rep("", tmp.n)
  } else {
    partable$label <- as.character(partable$label)
  }

  # order them nicely: id lhs op rhs group
  idx <- match(c("id", "lhs", "op", "rhs", "user", "block", "group",
    "free", "ustart", "exo", "label"),
  names(partable))
  tmp <- partable[idx]
  partable <- c(tmp, partable[-idx])

  # add start column
  if (start) {
    if (is.null(partable$start)) {
      partable$start <- lav_start(start.method = "simple",
        lavpartable = partable)
    }
  }
  attr(partable, "ovda") <- ovda
  attr(partable, "vnames") <- lav_partable_vnames(partable, "*")
  partable
}

# initial version: YR 03/05/2017

# major change: YR 14/06/2022 for 0.6-12
# - summary() is now silent if not printed
# - here, we only collect the necessary ingredients, and store them in a
#   a list
# - the result is a S3 class lavaan.summary
# - the actual printing is done by lav_summary_print (see lav_print.R)

# YR 26 July 2022: add fm.args= argument to change the way (some) fit measures
#                  are computed
# YR 24 Sept 2022: add efa= argument
# YR 19 Nov  2023: add remove.unused= argument
# TDJ 28 March 2024: deprecate std.nox= argument ("std.nox" can be %in% standardized=)

# create summary of a lavaan object
lav_object_summary <- function(object, header = TRUE,
                               fit.measures = FALSE,
                               baseline.model = NULL,
                               h1.model = NULL,
                               fm.args =
                                 list(
                                   standard.test = "default",
                                   scaled.test = "default",
                                   rmsea.ci.level = 0.90,
                                   rmsea.h0.closefit = 0.05,
                                   rmsea.h0.notclosefit = 0.08
                                 ),
                               estimates = TRUE,
                               ci = FALSE,
                               fmi = FALSE,
                               standardized = FALSE,
                               std = standardized,
                               remove.system.eq = TRUE,
                               remove.eq = TRUE,
                               remove.ineq = TRUE,
                               remove.def = FALSE,
                               remove.nonfree = FALSE,
                               remove.step1 = TRUE,
                               remove.unused = TRUE,
                               plabel = FALSE,
                               cov.std = TRUE,
                               rsquare = FALSE,
                               efa = FALSE,
                               efa.args =
                                 list(
                                   lambda = TRUE,
                                   theta = TRUE,
                                   psi = TRUE,
                                   eigenvalues = TRUE,
                                   sumsq.table = TRUE,
                                   lambda.structure = FALSE,
                                   fs.determinacy = FALSE,
                                   se = FALSE,
                                   zstat = FALSE,
                                   pvalue = FALSE
                                 ),
                               modindices = FALSE,
                               srmr.close.h0 = NULL) {

  # check object
  object <- lav_object_check_version(object)

  # default fm.args
  default.fm.args <- list(
    standard.test = "default",
    scaled.test = "default",
    rmsea.ci.level = 0.90,
    rmsea.close.h0 = 0.05,
    rmsea.notclose.h0 = 0.08,
    robust = TRUE,
    cat.check.pd = TRUE
  )
  if (is.logical(fit.measures)) {
    if (fit.measures) {
      fit.measures <- "default"
    } else {
      fit.measures <- "none"
    }
  }
  if (!missing(fm.args)) {
    lav_deprecated_args("fit.measures", "fm.args")
    fm.args <- modifyList(default.fm.args, fm.args)
  } else {
    fm.args <- default.fm.args
  }
  if (is.list(fit.measures)) {
    if (is.null(names(fit.measures)) ||
        is.null(fit.measures$fit.measures)) {
      lav_msg_stop(gettextf(
        "If %s is a list, it must contain a named element %s.",
        "fit.measures"
      ))
    }
    temp <- fit.measures$fit.measures
    fit.measures$fit.measures <- NULL
    fm.args <- modifyList(default.fm.args, fit.measures)
    fit.measures <- temp
  }


  # return a list with the main ingredients
  res <- list()

  # this is to avoid partial matching of 'std' with std.nox
  if (is.logical(std) && is.logical(standardized)) {
    standardized <- std || standardized
  } else {
    # At least 1 is not logical. Retain only valid standardization options.
    standardized <- intersect(union(tolower(std), tolower(standardized)),
                              c("std.lv","std.all","std.nox"))
  }

  # create the 'short' summary
  if (header) {
    # 1. collect header information
    VERSION <- object@version

    res$header <- list(
      lavaan.version = VERSION,
      sam.approach = !is.null(object@internal$sam.method),
      optim.method = object@Options$optim.method,
      optim.iterations = object@optim$iterations,
      optim.converged = object@optim$converged
    )

    # sam or sem?
    if (!is.null(object@internal$sam.method)) {
      # SAM version

      # 2. sam header
      res$sam.header <-
        list(
          sam.method = object@internal$sam.method,
          sam.local.options = object@internal$sam.local.options,
          sam.mm.list = object@internal$sam.mm.list,
          sam.mm.estimator = object@internal$sam.mm.estimator,
          sam.struc.estimator = object@internal$sam.struc.estimator
        )

      # 3. no EFA (for now)?

      # 4. summarize lavdata
      res$data <- lav_data_summary_short(object@Data)

      # 5a. sam local test statistics
      res$sam <- list(
        sam.method = object@internal$sam.method,
        sam.mm.table = object@internal$sam.mm.table,
        sam.mm.rel = object@internal$sam.mm.rel,
        sam.struc.fit = object@internal$sam.struc.fit,
        ngroups = object@Data@ngroups,
        group.label = object@Data@group.label,
        nlevels = object@Data@nlevels,
        level.label = object@Data@level.label,
        block.label = object@Data@block.label
      )

      # 5b. global test statistics (for global only)
      if (object@internal$sam.method == "global") {
        res$test <- object@test
      }
    } else {
      # SEM version

      # 2. summarize optim info (including estimator)
      nrow.ceq.jac <- nrow(object@Model@ceq.JAC)
      #if (object@Model@ceq.simple.only) {
        # not needed, as nrow.ceq.jac is already zero
      #  nrow.ceq.jac <- 0L
      #}
      cin.simple.only <- FALSE
      ceq.simple.only <- FALSE
      cin.simple.only <- object@Model@cin.simple.only
      ceq.simple.only <- object@Model@ceq.simple.only
      nrow.cin.jac <- nrow(object@Model@cin.JAC)
      if (cin.simple.only) {
        nrow.cin.jac <- 0L
      }
      if (ceq.simple.only && cin.simple.only) {
        nrow.con.jac <- 0L
        con.jac.rank <- 0L
      } else {
        nrow.con.jac <- nrow(object@Model@con.jac)
        con.jac.rank <- qr(object@Model@con.jac)$rank
      }

      res$optim <- list(
        estimator = object@Options$estimator,
        estimator.args = object@Options$estimator.args,
        optim.method = object@Options$optim.method,
        npar = object@Model@nx.free,
        eq.constraints = object@Model@eq.constraints,
        nrow.ceq.jac = nrow.ceq.jac,
        nrow.cin.jac = nrow.cin.jac,
        nrow.con.jac = nrow.con.jac,
        con.jac.rank = con.jac.rank
      )


      # 3. if EFA/ESEM, summarize rotation info
      if (object@Model@nefa > 0L) {
        res$rotation <-
          list(
            rotation = object@Options$rotation,
            rotation.args = object@Options$rotation.args
          )
      }

      # 4. summarize lavdata
      res$data <- lav_data_summary_short(object@Data)

      # 5. test statistics
      TEST <- object@test
      # TDJ: check for user-supplied h1 model
      if (!is.null(object@external$h1.model)) {
        stopifnot(inherits(object@external$h1.model, "lavaan"))
        ## update @test slot
        TEST <- lav_update_test_custom_h1(lav_obj_h0 = object,
                                          lav_obj_h1 = object@external$h1.model)@test
      }
      # double check if we have attr(TEST, "info") (perhaps old object?)
      if (is.null(attr(TEST, "info"))) {
        lavdata <- object@Data
        lavoptions <- object@Options
        attr(TEST, "info") <-
          list(
            ngroups = lavdata@ngroups,
            group.label = lavdata@group.label,
            information = lavoptions$information,
            h1.information = lavoptions$h1.information,
            observed.information = lavoptions$observed.information
          )
      }
      res$test <- TEST
    } # regular sem
  } # header

  # efa-related info
  if (efa) {
    res$efa <- lav_efa_summary(object, efa.args = efa.args)
  } # efa

  # only if requested, add the additional fit measures
  if (fit.measures != "none") {
    # some early warnings (to avoid a hard stop)
    if (object@Data@data.type == "none") {
      lav_msg_warn(gettext(
        "fit measures not available if there is no data"))
    } else if (length(object@Options$test) == 1L &&
      object@Options$test == "none") {
      lav_msg_warn(gettext(
        "fit measures not available if test = \"none\""))
    } else if (object@optim$npar > 0L && !object@optim$converged) {
      lav_msg_warn(gettext(
        "fit measures not available if model did not converge"))
    } else {
      FIT <- lav_fit_measures(object,
       fit.measures = c(list(fit.measures = fit.measures), fm.args),
       baseline.model = baseline.model,
       h1.model = h1.model)
      res$fit <- FIT
    }
  }

  # main ingredient: the parameter table
  if (estimates) {
    PE <- lavParameterEstimates(object,
      ci = ci, standardized = standardized,
      rsquare = rsquare, fmi = fmi,
      cov.std = cov.std,
      remove.eq = remove.eq, remove.system.eq = remove.system.eq,
      remove.ineq = remove.ineq, remove.def = remove.def,
      remove.nonfree = remove.nonfree,
      remove.step1 = remove.step1,
      remove.unused = remove.unused,
      plabel = plabel,
      output = "text",
      header = TRUE
    )
    res$pe <- as.data.frame(PE)
  }

  # modification indices?
  if (is.logical(modindices)) {
    if (modindices) modindices <- list(standardized = TRUE, cov.std = cov.std)
  }
  if (is.list(modindices)) {
    MI <- do.call("modificationIndices", c(list(object = object), modindices))
    res$mi <- MI
  }

  # create lavaan.summary S3 class
  class(res) <- c("lavaan.summary", "list")

  res
}

# what are the block values (not necessarily integers)
lav_partable_block_values <- function(partable) {
  if (is.null(partable$block)) {
    block.values <- 1L
  } else {
    # always integers
    tmp <- partable$block[partable$block > 0L & # non-zero only
      !partable$op %in% c("==", "<", ">", ":=")]
    block.values <- unique(na.omit(tmp)) # could be, eg, '2' only
  }

  block.values
}

# guess number of blocks from a partable
lav_partable_nblocks <- function(partable) {
  length(lav_partable_block_values(partable))
}

# what are the group values (not necessarily integers)
lav_partable_group_values <- function(partable) {
  # FLAT?
  if (any(partable$op == ":")) {
    colon.idx <- which(partable$op == ":" &
      tolower(partable$lhs) == "group")
    if (length(colon.idx) > 0L) {
      group.values <- unique(partable$rhs[colon.idx])
    }
    # regular partable
  } else if (is.null(partable$group)) {
    group.values <- 1L
  } else if (is.numeric(partable$group)) {
    tmp <- partable$group[partable$group > 0L &
      !partable$op %in% c("==", "<", ">", ":=")]
    group.values <- unique(na.omit(tmp))
  } else { # character
    tmp <- partable$group[nchar(partable$group) > 0L &
      !partable$op %in% c("==", "<", ">", ":=")]
    group.values <- unique(na.omit(tmp))
  }

  group.values
}

# guess number of groups from a partable
lav_partable_ngroups <- function(partable) {
  length(lav_partable_group_values(partable))
}

# what are the level values (not necessarily integers)
lav_partable_level_values <- function(partable) {
  # FLAT?
  if (any(partable$op == ":")) {
    colon.idx <- which(partable$op == ":" &
      tolower(partable$lhs) == "level")
    level.values <- integer(0L)
    if (length(colon.idx) > 0L) {
      level.values <- unique(partable$rhs[colon.idx])
    }
    # regular partable
  } else if (is.null(partable$level)) {
    level.values <- 1L
  } else if (is.numeric(partable$level)) {
    tmp <- partable$level[partable$level > 0L &
      !partable$op %in% c("==", "<", ">", ":=")]
    level.values <- unique(na.omit(tmp))
  } else { # character
    tmp <- partable$level[nchar(partable$level) > 0L &
      !partable$op %in% c("==", "<", ">", ":=")]
    level.values <- unique(na.omit(tmp))
  }

  level.values
}

# guess number of levels from a partable
lav_partable_nlevels <- function(partable) {
  length(lav_partable_level_values(partable))
}

# efa sets values
lav_partable_efa_values <- function(partable) {
  if (is.null(partable$efa)) {
    efa.values <- character(0L)
  } else { # should be character
    tmp.efa <- as.character(partable$efa)
    tmp <- tmp.efa[nchar(tmp.efa) > 0L &
      !partable$op %in% c("==", "<", ">", ":=")]
    efa.values <- unique(na.omit(tmp))
  }

  efa.values
}

# number of efa sets from a partable
lav_partable_nefa <- function(partable) {
  length(lav_partable_efa_values(partable))
}




# number of sample statistics per block
lav_partable_ndat <- function(partable) {
  # global
  meanstructure <- any(partable$op == "~1")
  fixed.x <- any(partable$exo > 0L & partable$free == 0L)
  conditional.x <- any(partable$exo > 0L & partable$op == "~")
  categorical <- any(partable$op == "|")
  composites <- any(partable$op == "<~")
  correlation <- any(partable$op == "~*~")
  if (categorical) {
    meanstructure <- TRUE
  }

  # blocks
  nblocks <- lav_partable_nblocks(partable)
  nlevels <- lav_partable_nlevels(partable)
  ndat <- integer(nblocks)

  for (b in seq_len(nblocks)) {
    # how many observed variables in this block?
    if (conditional.x) {
      ov.names <- lav_partable_vnames(partable, "ov.nox", block = b)
    } else {
      ov.names <- lav_partable_vnames(partable, "ov", block = b)
    }
    nvar <- length(ov.names)

    # pstar
    pstar <- nvar * (nvar + 1) / 2
    if (meanstructure) {
      pstar <- pstar + nvar

      # no meanstructure if within level, except ov.x which is not
      # decomposed
      if (nlevels > 1L && (b %% nlevels) == 1L) {
        # all zero
        pstar <- pstar - nvar

        # except within-only 'y'
        ov.names.y <- lav_partable_vnames(partable, "ov.nox", block = b)
        ov.names.y2 <- unlist(lav_partable_vnames(partable, "ov",
          block = seq_len(nblocks)[-b]
        ))
        ov.names.y <- ov.names.y[!ov.names.y %in% ov.names.y2]
        if (length(ov.names.y) > 0L) {
          pstar <- pstar + length(ov.names.y)
        }

        # except within-only 'x' (unless fixed.x)
        ov.names.x <- lav_partable_vnames(partable, "ov.x", block = b)
        ov.names.x2 <- unlist(lav_partable_vnames(partable, "ov",
          block = seq_len(nblocks)[-b]
        ))
        ov.names.x <- ov.names.x[!ov.names.x %in% ov.names.x2]
        if (!fixed.x && length(ov.names.x) > 0L) {
          pstar <- pstar + length(ov.names.x)
        }
      }
    }

    ndat[b] <- pstar

    # correction for fixed.x?
    if (!conditional.x && fixed.x) {
      ov.names.x <- lav_partable_vnames(partable, "ov.x", block = b)
      nvar.x <- length(ov.names.x)
      pstar.x <- nvar.x * (nvar.x + 1) / 2
      if (meanstructure) {
        if (nlevels > 1L && (b %% nlevels) == 1L) {
          # do nothing, they are already removed
        } else {
          pstar.x <- pstar.x + nvar.x
        }
      }
      ndat[b] <- ndat[b] - pstar.x
    }

    # composites?
    if (composites) {
      ov.cind <- lav_partable_vnames(partable, "ov.cind", block = b)
      covar.idx <- which(partable$op == "~~" &
                         partable$lhs %in% ov.cind &
                         partable$rhs %in% ov.cind &
                         partable$free == 0L)
      ndat[b] <- ndat[b] - length(covar.idx)
    }

    # correction for ordinal data?
    if (categorical) {
      ov.names.x <- lav_partable_vnames(partable, "ov.x", block = b)
      nexo <- length(ov.names.x)
      ov.ord <- lav_partable_vnames(partable, "ov.ord", block = b)
      nvar.ord <- length(ov.ord)
      th <- lav_partable_vnames(partable, "th", block = b)
      nth <- length(th)
      # no variances
      ndat[b] <- ndat[b] - nvar.ord
      # no means
      ndat[b] <- ndat[b] - nvar.ord
      # but additional thresholds
      ndat[b] <- ndat[b] + nth
      # add slopes
      if (conditional.x) {
        ov.names.x <- lav_partable_vnames(partable, "ov.x", block = b)
        nexo <- length(ov.names.x)
        ndat[b] <- ndat[b] + (nvar * nexo)
      }
    }

    # correction for correlation not categorical
    if (correlation && !categorical) {
      ndat[b] <- ndat[b] - nvar
    }

    # correction for conditional.x not categorical
    if (conditional.x && !categorical) {
      ov.names.x <- lav_partable_vnames(partable, "ov.x", block = b)
      nexo <- length(ov.names.x)
      # add slopes
      ndat[b] <- ndat[b] + (nvar * nexo)
    }

    # correction for group proportions?
    group.idx <- which(partable$lhs == "group" &
      partable$op == "%" &
      partable$block == b)
    if (length(group.idx) > 0L) {
      # ndat <- ndat + (length(group.idx) - 1L) # G - 1 (sum to one)
      ndat[b] <- ndat[b] + 1L # poisson: each cell a parameter
    }
  } # blocks

  # sum over all blocks
  sum(ndat)
}

# total number of free parameters (ignoring equality constraints)
lav_partable_npar <- function(partable) {
  # we only assume non-zero values
  npar <- length(which(partable$free > 0L))
  npar
}

# global degrees of freedom: ndat - npar
# ignoring constraints! (not very useful)
#
# we need to find the rank of con.jac to find the exact amount
# of non-redundant equality constraints (this is done in lav_test.R)
lav_partable_df <- function(partable) {
  npar <- lav_partable_npar(partable)
  ndat <- lav_partable_ndat(partable)

  # degrees of freedom
  df <- ndat - npar

  as.integer(df)
}

# check order of covariances: we only fill the upper.tri
# therefore, we 'switch' lhs & rhs if they appear in the wrong order
lav_partable_covariance_reorder <- function(partable, # nolint
                                            ov.names = NULL,
                                            lv.names = NULL) {
  # shortcut
  cov.idx <- which(partable$op == "~~" & partable$lhs != partable$rhs)
  if (length(cov.idx) == 0L) {
    # nothing to do
    return(partable)
  }

  # get names
  if (is.null(ov.names)) {
    ov.names <- lav_partable_vnames(partable, "ov")
  } else {
    ov.names <- unlist(ov.names)
  }
  if (is.null(lv.names)) {
    lv.names <- lav_partable_vnames(partable, "lv")
    # add random slopes (if any)
    if (!is.null(partable$rv) && any(nchar(partable$rv) > 0L)) {
      rv.names <- unique(partable$rv[nchar(partable$rv) > 0L])
      lv.names <- c(lv.names, rv.names)
    }
  } else {
    lv.names <- unlist(lv.names)
  }
  lv.ov.names <- c(lv.names, ov.names)

  # identify wrong ordering
  lhs.idx <- match(partable$lhs[cov.idx], lv.ov.names)
  rhs.idx <- match(partable$rhs[cov.idx], lv.ov.names)
  swap.idx <- cov.idx[lhs.idx > rhs.idx]

  if (length(swap.idx) == 0L) {
    # nothing to do
    return(partable)
  }

  # swap!
  tmp <- partable$lhs[swap.idx]
  partable$lhs[swap.idx] <- partable$rhs[swap.idx]
  partable$rhs[swap.idx] <- tmp

  partable
}

# add a single parameter to an existing parameter table
lav_partable_add <- function(partable = NULL, add = list()) {
  # treat partable as list, not as a data.frame
  partable <- as.list(partable)

  # number of elements
  nel <- length(partable$lhs)

  # add copy of last row
  for (c in seq_len(length(partable))) {
    if (is.integer(partable[[c]][[1]])) {
      if (partable[[c]][nel] == 0L) {
        partable[[c]][nel + 1] <- 0L
      } else if (partable[[c]][nel] == 1L) {
        partable[[c]][nel + 1] <- 1L
      } else {
        partable[[c]][nel + 1] <- partable[[c]][nel] + 1L
      }
    } else if (is.character(partable[[c]][[1]])) {
      partable[[c]][nel + 1] <- ""
    } else if (is.numeric(partable[[c]][[1]])) {
      partable[[c]][nel + 1] <- 0
    } else {
      partable[[c]][nel + 1] <- partable[[c]][nel]
    }

    # replace
    if (names(partable)[c] %in% names(add)) {
      partable[[c]][nel + 1] <- add[[names(partable)[c]]]
    }
  }

  partable
}


# look for p2-row-idx of p1 elements
# p1 is usually a subset of p2
# return NA if not found
lav_partable_map_id_p1_in_p2 <- function(p1, p2, stopifnotfound = TRUE,
                                         exclude.nonpar = TRUE) {
  # check if we have a 'block' column (in both p1 and p2)
  if (is.null(p1$block)) {
    if (is.null(p1$group)) {
      p1$block <- rep.int(1L, length(p1$lhs))
    } else {
      p1$block <- p1$group
    }
  }
  if (is.null(p2$block)) {
    if (is.null(p2$group)) {
      p2$block <- rep.int(1L, length(p2$lhs))
    } else {
      p2$block <- p2$group
    }
  }

  # ALL rows from p1, or only 'parameters'?
  if (exclude.nonpar) {
    # get all parameters that have a '.p*' plabel
    # (they exclude "==", "<", ">", ":=")
    p1.idx <- which(grepl("\\.p", p1$plabel))
  } else {
    # all of it
    # note: block should be '0' in both p1 and p2
    p1.idx <- seq_len(length(p1$lhs))
  }
  np1 <- length(p1.idx)

  # return p2.id
  p2.id <- integer(np1)

  # check every parameter in p1
  for (i in seq_len(np1)) {
    # identify parameter in p1
    lhs <- p1$lhs[i]
    op <- p1$op[i]
    rhs <- p1$rhs[i]
    block <- p1$block[i]

    # search for corresponding parameter in p2
    p2.idx <- which(p2$lhs == lhs & p2$op == op & p2$rhs == rhs &
      p2$block == block)

    # found?
    if (length(p2.idx) == 0L) {
      if (stopifnotfound) {
        lav_msg_stop(gettext("parameter in p1 not found in p2:"),
          paste(lhs, op, rhs, "(block = ", block, ")", sep = " ")
        )
      } else {
        p2.id[i] <- as.integer(NA)
      }
    } else {
      p2.id[i] <- p2.idx
    }
  }

  p2.id
}
lav_partable_da2ovda <- function(partable) {
  # convert handling of ov.order = "data" with "da-operator elements"
  #         to "ovda attribute"
  if (any(partable$op == "da")) {
    da.idx <- which(partable$op == "da")
    ov.names.data <- partable$lhs[da.idx]
    temp <- lapply(partable, function(x) x[-da.idx])
    # names(temp) <- names(partable)
    attr(temp, "ovda") <- ov.names.data
    return(temp)
  }
  return(partable)
}

# print object from lavData class
#

setMethod(
  "show", "lavData",
  function(object) {
    # print 'lavData' object
    res <- lav_data_summary_short(object)
    lav_data_print_short(res, nd = 3L)
  }
)

# create summary information for @lavdata slot
lav_data_summary_short <- function(object) {
  # which object?
  if (inherits(object, "lavaan")) {
    # check object
    object <- lav_object_check_version(object)
    lavdata <- object@Data
  } else if (inherits(object, "lavData")) {
    lavdata <- object
  } else {
    lav_msg_stop(gettext("object must be lavaan or lavData object"))
  }

  # two or three columns (depends on nobs/norig)
  threecolumn <- FALSE
  for (g in 1:lavdata@ngroups) {
    if (lavdata@nobs[[g]] != lavdata@norig[[g]]) {
      threecolumn <- TRUE
      break
    }
  }

  # clustered data?
  clustered <- length(lavdata@cluster) > 0L

  # multilevel data?
  multilevel <- lavdata@nlevels > 1L

  # extract summary information
  datasummary <- list(
    ngroups = lavdata@ngroups,
    nobs = unlist(lavdata@nobs)
  )

  # norig?
  if (threecolumn) {
    datasummary$norig <- unlist(lavdata@norig)
  }

  # multiple groups?
  if (lavdata@ngroups > 1L) {
    datasummary$group.label <- lavdata@group.label
  }

  # sampling weights?
  if (!is.null(lavdata@weights[[1L]])) {
    datasummary$sampling.weights <- lavdata@sampling.weights
  }

  # clustered/multilevel data?
  if (clustered) {
    if (multilevel) {
      datasummary$nlevels <- lavdata@nlevels
    }
    datasummary$cluster <- lavdata@cluster

    if (lavdata@ngroups == 1L) {
      datasummary$nclusters <- unlist(lavdata@Lp[[1]]$nclusters)
    } else {
      tmp <- vector("list", length = lavdata@ngroups)
      for (g in seq_len(lavdata@ngroups)) {
        tmp[[g]] <- unlist(lavdata@Lp[[g]]$nclusters)
      }
      datasummary$nclusters <- tmp
    }
  }

  # missing data?
  if (!is.null(lavdata@Mp[[1L]])) {
    datasummary$npatterns <- sapply(lavdata@Mp, "[[", "npatterns")
    if (multilevel && !is.null(lavdata@Mp[[1L]]$Zp)) {
      datasummary$npatterns2 <- sapply(lapply(
        lavdata@Mp,
        "[[", "Zp"
      ), "[[", "npatterns")
    }
  }

  datasummary
}

lav_data_print_short <- function(object, nd = 3L) {
  # object should data summary
  if (inherits(object, "lavaan")) {
    object <- lav_data_summary_short(object)
  }
  datasummary <- object

  num.format <- paste("%", max(8L, nd + 5L), ".", nd, "f", sep = "")

  # threecolumn
  threecolumn <- !is.null(datasummary$norig)

  # multilevel?
  multilevel <- !is.null(datasummary$nlevels)

  # clustered?
  clustered <- !is.null(datasummary$cluster) && is.null(datasummary$nlevels)

  # header? no, for historical reasons only
  # cat("Data information:\n\n")

  c1 <- c2 <- c3 <- character(0L)

  # number of observations
  if (datasummary$ngroups == 1L) {
    if (threecolumn) {
      c1 <- c(c1, "")
      c2 <- c(c2, "Used")
      c3 <- c(c3, "Total")
    }
    c1 <- c(c1, "Number of observations")
    c2 <- c(c2, datasummary$nobs)
    c3 <- c(c3, ifelse(threecolumn, datasummary$norig, ""))
  } else {
    c1 <- c(c1, "Number of observations per group:")
    if (threecolumn) {
      c2 <- c(c2, "Used")
      c3 <- c(c3, "Total")
    } else {
      c2 <- c(c2, "")
      c3 <- c(c3, "")
    }
    for (g in 1:datasummary$ngroups) {
      c1 <- c(c1, sprintf("  %-40s", datasummary$group.label[g]))
      c2 <- c(c2, datasummary$nobs[g])
      c3 <- c(c3, ifelse(threecolumn, datasummary$norig[g], ""))
    } # g
  }

  # number of clusters
  if (datasummary$ngroups == 1L) {
    if (multilevel) {
      for (l in 2:datasummary$nlevels) {
        c1 <- c(
          c1,
          paste("Number of clusters [",
            datasummary$cluster[l - 1], "]",
            sep = ""
          )
        )
        c2 <- c(c2, datasummary$nclusters[l])
        c3 <- c(c3, "")
      }
    } else if (clustered) {
      c1 <- c(c1, paste("Number of clusters [", datasummary$cluster, "]",
        sep = ""
      ))
      c2 <- c(c2, datasummary$nclusters[2])
      c3 <- c(c3, "")
    }
  } else {
    if (multilevel) {
      for (l in 2:datasummary$nlevels) {
        c1 <- c(
          c1,
          paste("Number of clusters [", datasummary$cluster[l - 1], "]:",
            sep = ""
          )
        )
        c2 <- c(c2, "")
        c3 <- c(c3, "")
        for (g in 1:datasummary$ngroups) {
          c1 <- c(c1, sprintf("  %-40s", datasummary$group.label[g]))
          c2 <- c(c2, datasummary$nclusters[[g]][l])
          c3 <- c(c3, "")
        }
      }
    } else if (clustered) {
      c1 <- c(
        c1,
        paste("Number of clusters [", datasummary$cluster, "]:", sep = "")
      )
      c2 <- c(c2, "")
      c3 <- c(c3, "")
      for (g in 1:datasummary$ngroups) {
        c1 <- c(c1, sprintf("  %-40s", datasummary$group.label[g]))
        c2 <- c(c2, datasummary$nclusters[[g]][2])
        c3 <- c(c3, "")
      }
    }
  }

  # missing patterns?
  if (!is.null(datasummary$npatterns)) {
    if (datasummary$ngroups == 1L) {
      if (multilevel) {
        c1 <- c(c1, "Number of missing patterns -- level 1")
        c2 <- c(c2, datasummary$npatterns)
        c3 <- c(c3, "")
        if (!is.null(datasummary$npatterns2)) {
          c1 <- c(c1, "Number of missing patterns -- level 2")
          c2 <- c(c2, datasummary$npatterns2)
          c3 <- c(c3, "")
        }
      } else {
        c1 <- c(c1, "Number of missing patterns")
        c2 <- c(c2, datasummary$npatterns)
        c3 <- c(c3, "")
      }
    } else {
      if (multilevel) {
        c1 <- c(c1, "Number of missing patterns per group:")
        c2 <- c(c2, "")
        c3 <- c(c3, "")
        for (g in 1:datasummary$ngroups) {
          c1 <- c(
            c1,
            paste(sprintf(
              "  %-40s",
              datasummary$group.label[g]
            ), "-- level 1")
          )
          c2 <- c(c2, datasummary$npatterns[g])
          c3 <- c(c3, "")
          if (!is.null(datasummary$npatterns2)) {
            c1 <- c(
              c1,
              paste(sprintf(
                "  %-40s",
                datasummary$group.label[g]
              ), "-- level 2")
            )
            c2 <- c(c2, datasummary$npatterns2[g])
            c3 <- c(c3, "")
          }
        }
      } else {
        c1 <- c(c1, "Number of missing patterns per group:")
        c2 <- c(c2, "")
        c3 <- c(c3, "")
        for (g in 1:datasummary$ngroups) {
          c1 <- c(c1, sprintf("  %-40s", datasummary$group.label[g]))
          c2 <- c(c2, datasummary$npatterns[g])
          c3 <- c(c3, "")
        }
      }
    }
  }

  # sampling weights?
  if (!is.null(datasummary$sampling.weights)) {
    c1 <- c(c1, "Sampling weights variable")
    c2 <- c(c2, datasummary$sampling.weights)
    c3 <- c(c3, "")
  }

  # format c1/c2
  c1 <- format(c1, width = 43L)
  c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right")
  c3 <- format(c3, width = 8L + nd, justify = "right")

  # create character matrix
  if (threecolumn) {
    M <- cbind(c1, c2, c3, deparse.level = 0)
  } else {
    M <- cbind(c1, c2, deparse.level = 0)
  }
  colnames(M) <- rep("", ncol(M))
  rownames(M) <- rep(" ", nrow(M))

  # print
  write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)

  invisible(M)
}

# constructor of the matrix lavoptions$representation
#
# initial version: YR 22/11/2010
# - YR 14 Jan 2014: moved to lav_model.R
# - YR 18 Nov 2014: more efficient handling of linear equality constraints
# - YR 02 Dec 2014: allow for bare-minimum parameter tables
# - YR 25 Jan 2017: collect options in lavoptions
# - YR 12 Mar 2021: add lavpta as argument; create model attributes (ma)
# - YR 21 Jan 2025: add composites

# construct MATRIX lavoptions$representation of the model
lav_model <- function(lavpartable = NULL,                          # nolint
                      lavoptions = NULL,
                      th.idx = list()) {
  # handle bare-minimum partables
  lavpartable <- lav_partable_complete(lavpartable)
  lavpta = lav_partable_attributes(lavpartable)
  lavpartable <- lav_partable_set_cache(lavpartable, lavpta)

  # global info from user model
  nblocks <- lav_partable_nblocks(lavpartable)
  ngroups <- lav_partable_ngroups(lavpartable)
  meanstructure <- any(lavpartable$op == "~1")
  correlation <- lavoptions$correlation
  if (is.null(correlation)) {
    correlation <- FALSE
  }
  composites.option <- lavoptions$composites
  if (is.null(composites.option)) {
    composites.option <- TRUE
  }
  composites <- any(lavpartable$op == "<~") && composites.option
  categorical <- any(lavpartable$op == "|")
  if (categorical) {
    meanstructure <- TRUE

    # handle th.idx if length(th.idx) != nblocks
    if (nblocks != length(th.idx)) {
      th.idx <- rep(th.idx, each = nblocks)
    }
  }
  group.w.free <- any(lavpartable$lhs == "group" & lavpartable$op == "%")
  multilevel <- FALSE
  if (!is.null(lavpartable$level)) {
    nlevels <- lav_partable_nlevels(lavpartable)
    if (nlevels > 1L) {
      multilevel <- TRUE
    }
  } else {
    nlevels <- 1L
  }

  nefa <- lav_partable_nefa(lavpartable)
  if (nefa > 0L) {
    efa.values <- lav_partable_efa_values(lavpartable)
  }

  # check for simple equality constraints
  eq.simple <- any(lavpartable$free > 0L & duplicated(lavpartable$free))
  if (eq.simple) {
    # just like in <0.5-18, add (temporary) 'unco' column
    # so we can fill in x.unco.idx
    lavpartable$unco <- integer(length(lavpartable$id))
    idx.free <- which(lavpartable$free > 0L)
    lavpartable$unco[idx.free] <- seq_along(idx.free)
  }

  # handle variable definitions and (in)equality constraints
  tmp.con <- lav_constraints_parse(
    partable = lavpartable,
    constraints = NULL
  )

  # handle *linear* equality constraints special
  if (tmp.con$ceq.linear.only.flag) {
    con.jac <- tmp.con$ceq.JAC
    con.lambda <- numeric(nrow(tmp.con$ceq.JAC))
    attr(con.jac, "inactive.idx") <- integer(0L)
    attr(con.jac, "ceq.idx") <- seq_len(nrow(tmp.con$ceq.JAC))
  } else {
    con.jac <- matrix(0, 0, 0)
    con.lambda <- numeric(0)
  }

  # select model matrices
  if (lavoptions$representation == "LISREL") {
    tmp.rep <- lav_lisrel(lavpartable, target = NULL, extra = TRUE,
                          allow.composites = composites)
  } else if (lavoptions$representation == "RAM") {
    tmp.rep <- lav_ram(lavpartable, target = NULL, extra = TRUE)
  } else {
    lav_msg_stop(gettextf(
      "%1$s argument must be either %2$s or %3$s",
      "representation", "LISREL", "RAM"))
  }
  if (lav_debug()) print(tmp.rep)

  # FIXME: check for non-existing parameters
  bad.idx <- which((tmp.rep$mat == "" | is.na(tmp.rep$row) | is.na(tmp.rep$col)) &
    !lavpartable$op %in% c("==", "<", ">", ":="))

  if (length(bad.idx) > 0L) {
    this.formula <- paste(lavpartable$lhs[bad.idx[1]],
      lavpartable$op[bad.idx[1]],
      lavpartable$rhs[bad.idx[1]],
      sep = " "
    )
    if (lavoptions$representation == "LISREL") {
      lav_msg_stop(gettextf(
        "a model parameter is not defined in the LISREL representation %s.
        Upgrade to latent variables or consider using representation = 'RAM'.",
        this.formula)      )
    } else {
      lav_msg_stop(
        gettextf("parameter is not defined: %s", this.formula)
      )
    }
  }

  # prepare nG-sized slots
  tmp.ng <- sum(unlist(attr(tmp.rep, "mmNumber")))
  tmp.glist <- vector(mode = "list", tmp.ng)
  names(tmp.glist) <- unlist(attr(tmp.rep, "mmNames"))
  dim.names <- vector(mode = "list", length = tmp.ng)
  is.symmetric <- logical(tmp.ng)
  mm.size <- integer(tmp.ng)

  m.free.idx <- m.user.idx <- vector(mode = "list", length = tmp.ng)
  x.free.idx <- x.unco.idx <- x.user.idx <- vector(
    mode = "list",
    length = tmp.ng
  )

  # prepare nblocks-sized slots
  nvar <- integer(nblocks)
  nmat <- unlist(attr(tmp.rep, "mmNumber"))
  num.idx <- vector("list", length = nblocks)
  nexo <- integer(nblocks)
  ov.x.dummy.ov.idx <- vector(mode = "list", length = nblocks)
  ov.x.dummy.lv.idx <- vector(mode = "list", length = nblocks)
  ov.y.dummy.ov.idx <- vector(mode = "list", length = nblocks)
  ov.y.dummy.lv.idx <- vector(mode = "list", length = nblocks)
  ov.efa.idx <- vector(mode = "list", length = nblocks)
  lv.efa.idx <- vector(mode = "list", length = nblocks)

  offset <- 0L
  # keep track of ov.names across blocks
  for (g in 1:nblocks) {
    # observed and latent variables for this block
    ov.names <- lav_partable_vnames(lavpartable, "ov", block = g)
    ov.names.nox <- lav_partable_vnames(lavpartable, "ov.nox", block = g)
    ov.names.x <- lav_partable_vnames(lavpartable, "ov.x", block = g)
    ov.num <- lav_partable_vnames(lavpartable, "ov.num", block = g)
    if (lavoptions$conditional.x) {
      if (nlevels > 1L) {
        if (ngroups == 1L) {
          other.block.names <- lav_partable_vnames(lavpartable, "ov",
            block = seq_len(nblocks)[-g]
          )
        } else {
          # TEST ME!
          # which group is this?
          this.group <- ceiling(g / nlevels)
          blocks.within.group <- (this.group - 1L) * nlevels + seq_len(nlevels)
          other.block.names <- lav_partable_vnames(lavpartable, "ov",
            block = blocks.within.group[-g]
          )
        }


        if (length(ov.names.x) > 0L) {
          idx <- which(ov.names.x %in% other.block.names)
          if (length(idx) > 0L) {
            ov.names.nox <- unique(c(ov.names.nox, ov.names.x[idx]))
            ov.names.x <- ov.names.x[-idx]
            ov.names <- ov.names.nox
          }
        }
      }
      nvar[g] <- length(ov.names.nox)
      if (correlation) {
        num.idx[[g]] <- integer(0L)
      } else {
        num.idx[[g]] <- which(ov.names.nox %in% ov.num)
      }
    } else {
      nvar[g] <- length(ov.names)
      if (correlation) {
        num.idx[[g]] <- integer(0L)
      } else {
        num.idx[[g]] <- which(ov.names %in% ov.num)
      }
    }
    nexo[g] <- length(ov.names.x)

    if (nefa > 0L) {
      lv.names <- lav_partable_vnames(lavpartable, "lv", block = g)
    }

    # model matrices for this block
    mm.number <- attr(tmp.rep, "mmNumber")[[g]]
    mm.names <- attr(tmp.rep, "mmNames")[[g]]
    mm.symmetric <- attr(tmp.rep, "mmSymmetric")[[g]]
    mm.dim.names <- attr(tmp.rep, "mmDimNames")[[g]]
    mm.rows <- attr(tmp.rep, "mmRows")[[g]]
    mm.cols <- attr(tmp.rep, "mmCols")[[g]]

    for (mm in 1:mm.number) {
      # offset in tmp.glist
      offset <- offset + 1L

      # matrix size, symmetric, dim.names
      if (mm.symmetric[mm]) {
        tmp.n <- mm.rows[mm]
        mm.size <- as.integer(tmp.n * (tmp.n + 1) / 2)
      } else {
        mm.size <- as.integer(mm.rows[mm] * mm.cols[mm])
      }
      mm.size[offset] <- mm.size
      is.symmetric[offset] <- mm.symmetric[mm]
      dim.names[[offset]] <- mm.dim.names[[mm]]

      # select elements for this matrix
      idx <- which(lavpartable$block == g & tmp.rep$mat == mm.names[mm])

      # create empty `pattern' matrix
      # FIXME: one day, we may want to use sparse matrices...
      #        but they should not slow things down!
      tmp <- matrix(0L,
        nrow = mm.rows[mm],
        ncol = mm.cols[mm]
      )

      # 1. first assign free values only, to get vector index
      #    -> to be used in lav_model_objective
      tmp[cbind(tmp.rep$row[idx], tmp.rep$col[idx])] <- lavpartable$free[idx]
      if (mm.symmetric[mm]) {
        # NOTE: we assume everything is in the UPPER tri!
        tmp.tt <- t(tmp)
        tmp[lower.tri(tmp)] <- tmp.tt[lower.tri(tmp.tt)]
      }
      m.free.idx[[offset]] <- which(tmp > 0)
      x.free.idx[[offset]] <- tmp[which(tmp > 0)]

      # 2. if simple equality constraints, unconstrained free parameters
      #    -> to be used in lav_model_gradient
      if (eq.simple) {
        tmp[cbind(
          tmp.rep$row[idx],
          tmp.rep$col[idx]
        )] <- lavpartable$unco[idx]
        if (mm.symmetric[mm]) {
          # NOTE: we assume everything is in the UPPER tri!
          tmp.tt <- t(tmp)
          tmp[lower.tri(tmp)] <- tmp.tt[lower.tri(tmp.tt)]
        }
        # m.unco.idx[[offset]] <-     which(tmp > 0)
        x.unco.idx[[offset]] <- tmp[which(tmp > 0)]
      } else {
        # m.unco.idx[[offset]] <- m.free.idx[[offset]]
        x.unco.idx[[offset]] <- x.free.idx[[offset]]
      }

      # 3. general mapping between user and tmp.glist
      tmp[cbind(tmp.rep$row[idx], tmp.rep$col[idx])] <- lavpartable$id[idx]
      if (mm.symmetric[mm]) {
        tmp.tt <- t(tmp)
        tmp[lower.tri(tmp)] <- tmp.tt[lower.tri(tmp.tt)]
      }
      m.user.idx[[offset]] <- which(tmp > 0)
      x.user.idx[[offset]] <- tmp[which(tmp > 0)]

      # 4. now assign starting/fixed values
      # create empty matrix
      # FIXME: again, we may want to use sparse matrices here...
      tmp <- matrix(0.0,
        nrow = mm.rows[mm],
        ncol = mm.cols[mm]
      )
      tmp[cbind(tmp.rep$row[idx], tmp.rep$col[idx])] <- lavpartable$start[idx]
      if (mm.symmetric[mm]) {
        tmp.tt <- t(tmp)
        tmp[lower.tri(tmp)] <- tmp.tt[lower.tri(tmp.tt)]
      }

      # 4b. override with cov.x (if conditional.x = TRUE)
      # new in 0.6-1
      # shouldn't be needed, if lavpartable$start contains cov.x values
      # if(mm.names[mm] == "cov.x") {
      #    tmp <- cov.x[[g]]
      # }
      # 4c. override with mean.x (if conditional.x = TRUE)
      # new in 0.6-1
      # shouldn't be needed, if lavpartable$start contains mean.x values
      # if(mm.names[mm] == "mean.x") {
      #    tmp <- as.matrix(mean.x[[g]])
      # }

      # representation specific stuff
      if (lavoptions$representation == "LISREL" &&
        mm.names[mm] == "lambda") {
        ov.dummy.names.nox <- attr(tmp.rep, "ov.dummy.names.nox")[[g]]
        ov.dummy.names.x <- attr(tmp.rep, "ov.dummy.names.x")[[g]]
        ov.dummy.names <- c(ov.dummy.names.nox, ov.dummy.names.x)
        # define dummy latent variables
        if (length(ov.dummy.names)) {
          # in this case, lv.names will be extended with the dummys
          tmp.lv.names <- mm.dim.names$psi[[1]]
          row.tmp.idx <- match(ov.dummy.names, ov.names)
          col.tmp.idx <- match(ov.dummy.names, tmp.lv.names)
          # Fix lambda values to 1.0
          tmp[cbind(row.tmp.idx, col.tmp.idx)] <- 1.0

          ov.x.dummy.ov.idx[[g]] <- match(ov.dummy.names.x, ov.names)
          ov.x.dummy.lv.idx[[g]] <- match(ov.dummy.names.x, tmp.lv.names)
          ov.y.dummy.ov.idx[[g]] <- match(ov.dummy.names.nox, ov.names)
          ov.y.dummy.lv.idx[[g]] <- match(ov.dummy.names.nox, tmp.lv.names)
        }
      }

      # representation specific
      if (lavoptions$representation == "LISREL" && mm.names[mm] == "delta") {
        # only categorical values are listed in the lavpartable
        # but all remaining values should be 1.0
        idx <- which(tmp[, 1L] == 0.0)
        tmp[idx, 1L] <- 1.0
      }

      # representation specific
      if (lavoptions$representation == "RAM" && mm.names[mm] == "ov.idx") {
        tmp[1, ] <- attr(tmp.rep, "ov.idx")[[g]]
      }

      # assign matrix to tmp.glist
      tmp.glist[[offset]] <- tmp
    } # mm

    # efa related info
    if (nefa > 0L) {
      ov.efa.idx[[g]] <- vector("list", length = nefa)
      lv.efa.idx[[g]] <- vector("list", length = nefa)
      for (set in seq_len(nefa)) {
        # determine ov idx for this set
        ov.efa <-
          unique(lavpartable$rhs[lavpartable$op == "=~" &
            lavpartable$block == g &
            lavpartable$efa == efa.values[set]])
        ov.efa.idx[[g]][[set]] <- match(ov.efa, ov.names)

        lv.efa <-
          unique(lavpartable$lhs[lavpartable$op == "=~" &
            lavpartable$block == g &
            lavpartable$efa == efa.values[set]])
        lv.efa.idx[[g]][[set]] <- match(lv.efa, lv.names)
      }
      names(ov.efa.idx[[g]]) <- efa.values
      names(lv.efa.idx[[g]]) <- efa.values
    } # efa

    # set variances composites (new in 0.6-20)
    if (composites) {
      mm.in.group <- 1:nmat[g] + cumsum(c(0L, nmat))[g]
      tmp.glist[mm.in.group] <-
        lav_lisrel_composites_variances(tmp.glist[mm.in.group])
    }
  } # g

  # fixed.x parameters?
  # fixed.x <- any(lavpartable$exo > 0L & lavpartable$free == 0L)
  # if(categorical) {
  #    fixed.x <- TRUE
  # }

  # dirty hack to mimic MUML
  if (!is.null(lavoptions$tech.muml.scale)) {
    lav_msg_warn(gettext("using muml scale in group 2"))

    # find matrix
    lambda.idx <- which(names(tmp.glist) == "lambda")[2L]

    # find rows/cols
    b.names <- paste0("b", ov.names) ## ad-hoc assumption!!!
    tmp.cols <- match(b.names, tmp.lv.names)
    tmp.rows <- seq_len(nvar[2])
    stopifnot(length(tmp.cols) == length(tmp.rows))
    tmp.glist[[lambda.idx]][cbind(tmp.rows, tmp.cols)] <-
      lavoptions$tech.muml.scale
  }

  # which free parameters are observed variances?
  ov.names <- lav_partable_vnames(lavpartable, "ov")
  x.free.var.idx <- lavpartable$free[lavpartable$free &
    # !duplicated(lavpartable$free) &
    lavpartable$lhs %in% ov.names &
    lavpartable$op == "~~" &
    lavpartable$lhs == lavpartable$rhs]

  rv.lv <- rv.ov <- list()
  if (multilevel) {
    # store information about random slopes (if any)
    lv.names <- lav_partable_vnames(lavpartable, "lv")
    # we should also add splitted-y names (x) to lv.names
    # FIXME: make this work for multiple work multilevel
    level.values <- lav_partable_level_values(lavpartable)
    ovx1 <- lav_object_vnames(lavpartable, "ov.x", level = level.values[1])
    ovx2 <- lav_object_vnames(lavpartable, "ov.x", level = level.values[2])
    ovx12 <- ovx2[ovx2 %in% ovx1]
    lv.names <- c(lv.names, ovx12)

    # RV LV
    rv.idx <- which(nchar(lavpartable$rv) > 0L &
      lavpartable$level == level.values[1] &
      lavpartable$rhs %in% lv.names)
    if (length(rv.idx)) {
      rv.lv <- lapply(rv.idx, function(x) {
        c(lavpartable$lhs[x], lavpartable$rhs[x])
      })
      names(rv.lv) <- lavpartable$rv[rv.idx]
    }

    # RV OV
    rv.idx <- which(nchar(lavpartable$rv) > 0L &
      lavpartable$level == level.values[1] &
      !lavpartable$rhs %in% lv.names)
    if (length(rv.idx)) {
      rv.ov <- lapply(rv.idx, function(x) {
        c(lavpartable$lhs[x], lavpartable$rhs[x])
      })
      names(rv.ov) <- lavpartable$rv[rv.idx]
    }
  } # multilevel

  # new in 0.6-9: model properties
  modprop <- lav_model_properties(
    GLIST = tmp.glist,
    lavpartable = lavpartable,
    nmat = nmat,
    m.free.idx = m.free.idx
  )

  tmp.model <- new("lavModel",
    GLIST = tmp.glist,
    dimNames = dim.names,
    isSymmetric = is.symmetric,
    mmSize = mm.size,
    representation = lavoptions$representation,
    modprop = modprop,
    meanstructure = meanstructure,
    correlation = correlation,
    composites = composites,
    categorical = categorical,
    multilevel = multilevel,
    link = lavoptions$link,
    nblocks = nblocks,
    ngroups = ngroups, # breaks rsem????
    nefa = nefa,
    group.w.free = group.w.free,
    nmat = nmat,
    nvar = nvar,
    num.idx = num.idx,
    th.idx = th.idx,
    nx.free = max(lavpartable$free),
    nx.unco = if (is.null(lavpartable$unco)) {
      max(lavpartable$free)
    } else {
      max(lavpartable$unco)
    },
    nx.user = max(lavpartable$id),
    m.free.idx = m.free.idx,
    x.free.idx = x.free.idx,
    x.free.var.idx = x.free.var.idx,
    # m.unco.idx=m.unco.idx,
    x.unco.idx = x.unco.idx,
    m.user.idx = m.user.idx,
    x.user.idx = x.user.idx,
    x.def.idx = which(lavpartable$op == ":="),
    x.ceq.idx = which(lavpartable$op == "=="),
    x.cin.idx = which(lavpartable$op == ">" | lavpartable$op == "<"),
    ceq.simple.only = tmp.con$ceq.simple.only,
    ceq.simple.K = tmp.con$ceq.simple.K,
    eq.constraints = tmp.con$ceq.linear.only.flag,
    eq.constraints.K = tmp.con$ceq.JAC.NULL,
    eq.constraints.k0 = tmp.con$ceq.rhs.NULL,
    def.function = tmp.con$def.function,
    ceq.function = tmp.con$ceq.function,
    ceq.JAC = tmp.con$ceq.JAC,
    ceq.rhs = tmp.con$ceq.rhs,
    ceq.jacobian = tmp.con$ceq.jacobian,
    ceq.linear.idx = tmp.con$ceq.linear.idx,
    ceq.nonlinear.idx = tmp.con$ceq.nonlinear.idx,
    cin.simple.only = tmp.con$cin.simple.only,
    cin.function = tmp.con$cin.function,
    cin.JAC = tmp.con$cin.JAC,
    cin.rhs = tmp.con$cin.rhs,
    cin.jacobian = tmp.con$cin.jacobian,
    cin.linear.idx = tmp.con$cin.linear.idx,
    cin.nonlinear.idx = tmp.con$cin.nonlinear.idx,
    con.jac = con.jac,
    con.lambda = con.lambda,
    nexo = nexo,
    fixed.x = lavoptions$fixed.x,
    conditional.x = lavoptions$conditional.x,
    parameterization = lavoptions$parameterization,
    ov.x.dummy.ov.idx = ov.x.dummy.ov.idx,
    ov.x.dummy.lv.idx = ov.x.dummy.lv.idx,
    ov.y.dummy.ov.idx = ov.y.dummy.ov.idx,
    ov.y.dummy.lv.idx = ov.y.dummy.lv.idx,
    ov.efa.idx = ov.efa.idx,
    lv.efa.idx = lv.efa.idx,
    rv.lv = rv.lv,
    rv.ov = rv.ov,
    estimator = lavoptions$estimator,
    estimator.args = lavoptions$estimator.args
  )

  if (lav_debug()) {
    cat("lavaan debug: lavaanModel\n")
    print(str(tmp.model))
    print(tmp.model@GLIST)
  }

  tmp.model
}

# for backwards compatibility
# tmp.model <- lav_model

# utility functions needed for lav_cfa_*

# compute THETA and PSI, given lambda using either ULS or GLS
# this function assumes:
# - THETA is diagonal
# - PSI is unrestricted
# - we assume W = S^{-1}
#
# YR 17 oct 2022: - add lower/upper bounds for theta (only to compute PSI)
#                 - use 'lambda' correction to ensure PSI is positive definite
# YR 02 feb 2023: - add psi.mapping.ML argument
lav_cfa_lambda2thetapsi <- function(lambda = NULL, S = NULL, S.inv = NULL,
                                    GLS = FALSE, psi.mapping.ML = FALSE,
                                    nobs = 20L) {
  LAMBDA <- as.matrix(lambda)
  nvar <- nrow(LAMBDA)
  nfac <- ncol(LAMBDA)

  if (GLS) {
    # see Browne, 1974 section 4 case II
    if (is.null(S.inv)) {
      W <- solve(S)
    } else {
      W <- S.inv
    }
    tLW <- crossprod(LAMBDA, W)
    M <- solve(tLW %*% LAMBDA, tLW) # GLS mapping
    # D <- W %*% LAMBDA %*% M # symmmetric
    D <- crossprod(M, tLW)
    # theta <- solve(W*W - D*D, diag(W %*% S %*% W - D %*% S %*% D))
    theta <- try(solve(W * W - D * D, diag(W - D)), # because W == S^{-1}
      silent = TRUE
    )
    if (inherits(theta, "try-error")) {
      # what to do?
      lav_msg_warn(gettext(
        "problem computing THETA values; trying pace algorithm"))
      theta <- lav_efa_pace(S = S, nfactors = nfac, theta.only = TRUE)
    }
  } else {
    # see Hagglund 1982, section 4
    M <- solve(crossprod(LAMBDA), t(LAMBDA)) # ULS mapping function
    D <- LAMBDA %*% M
    theta <- try(solve(diag(nvar) - D * D, diag(S - (D %*% S %*% D))),
      silent = TRUE
    )
    if (inherits(theta, "try-error")) {
      # what to do?
      lav_msg_warn(gettext(
        "problem computing THETA values; trying pace algorithm"))
      theta <- lav_efa_pace(S = S, nfactors = nfac, theta.only = TRUE)
    }
  }
  theta.nobounds <- theta

  # ALWAYS check bounds for theta (only to to compute PSI)!
  theta.bounds <- TRUE
  if (theta.bounds) {
    diagS <- diag(S)
    # lower bound
    lower.bound <- diagS * 0 # * 0.01
    too.small.idx <- which(theta < lower.bound)
    if (length(too.small.idx) > 0L) {
      theta[too.small.idx] <- lower.bound[too.small.idx]
    }

    # upper bound
    upper.bound <- diagS * 1 # * 0.99
    too.large.idx <- which(theta > upper.bound)
    if (length(too.large.idx) > 0L) {
      theta[too.large.idx] <- upper.bound[too.large.idx]
    }
  }

  # psi
  diag.theta <- diag(theta, nvar)
  lambda <- try(lav_matrix_symmetric_diff_smallest_root(S, diag.theta),
    silent = TRUE
  )
  if (inherits(lambda, "try-error")) {
    lav_msg_warn(gettext("failed to compute lambda"))
    SminTheta <- S - diag.theta # and hope for the best
  } else {
    cutoff <- 1 + 1 / (nobs - 1)
    if (lambda < cutoff) {
      lambda.star <- lambda - 1 / (nobs - 1)
      SminTheta <- S - lambda.star * diag.theta
    } else {
      SminTheta <- S - diag.theta
    }
  }

  # just like local SAM
  if (psi.mapping.ML) {
    Ti <- 1 / theta
    zero.theta.idx <- which(abs(theta) < 0.01) # be conservative
    if (length(zero.theta.idx) > 0L) {
      Ti[zero.theta.idx] <- 1
    }
    M <- solve(t(LAMBDA) %*% diag(Ti, nvar) %*% LAMBDA) %*% t(LAMBDA) %*% diag(Ti, nvar)
    PSI <- M %*% SminTheta %*% t(M) # ML
  } else {
    PSI <- M %*% SminTheta %*% t(M) # ULS/GLS
  }

  # we take care of the bounds later!
  list(lambda = LAMBDA, theta = theta.nobounds, psi = PSI)
}

# compute PSI, given lambda and theta using either ULS, GLS, ML
# this function assumes:
# - THETA is diagonal
# - PSI is unrestricted
#
# YR 08 Mar 2023: - first version
lav_cfa_lambdatheta2psi <- function(lambda = NULL, theta = NULL, # vector!
                                    S = NULL, S.inv = NULL,
                                    mapping = "ML", nobs = 20L) {
  LAMBDA <- as.matrix(lambda)
  nvar <- nrow(LAMBDA)
  nfac <- ncol(LAMBDA)

  theta.nobounds <- theta

  # ALWAYS check bounds for theta to compute PSI
  diagS <- diag(S)
  # lower bound
  lower.bound <- diagS * 0 # * 0.01
  too.small.idx <- which(theta < lower.bound)
  if (length(too.small.idx) > 0L) {
    theta[too.small.idx] <- lower.bound[too.small.idx]
  }

  # upper bound
  upper.bound <- diagS * 1 # * 0.99
  too.large.idx <- which(theta > upper.bound)
  if (length(too.large.idx) > 0L) {
    theta[too.large.idx] <- upper.bound[too.large.idx]
  }

  # psi
  diag.theta <- diag(theta, nvar)
  lambda <- try(lav_matrix_symmetric_diff_smallest_root(S, diag.theta),
    silent = TRUE
  )
  if (inherits(lambda, "try-error")) {
    lav_msg_warn(gettext("failed to compute lambda"))
    SminTheta <- S - diag.theta # and hope for the best
  } else {
    cutoff <- 1 + 1 / (nobs - 1)
    if (lambda < cutoff) {
      lambda.star <- lambda - 1 / (nobs - 1)
      SminTheta <- S - lambda.star * diag.theta
    } else {
      SminTheta <- S - diag.theta
    }
  }

  # mapping matrix
  if (mapping == "ML") {
    Ti <- 1 / theta
    zero.theta.idx <- which(abs(theta) < 0.01) # be conservative
    if (length(zero.theta.idx) > 0L) {
      Ti[zero.theta.idx] <- 1
    }
    M <- solve(t(LAMBDA) %*% diag(Ti, nvar) %*% LAMBDA) %*% t(LAMBDA) %*% diag(Ti, nvar)
  } else if (mapping == "GLS") {
    if (is.null(S.inv)) {
      S.inv <- try(solve(S), silent = TRUE)
    }
    if (inherits(S.inv, "try-error")) {
      M <- tcrossprod(solve(crossprod(LAMBDA)), LAMBDA)
    } else {
      M <- solve(t(LAMBDA) %*% S.inv %*% LAMBDA) %*% t(LAMBDA) %*% S.inv
    }
  } else if (mapping == "ULS") {
    M <- tcrossprod(solve(crossprod(LAMBDA)), LAMBDA)
  }

  # compute PSI
  PSI <- M %*% SminTheta %*% t(M)

  PSI
}

# compute theta elements for a 1-factor model
lav_cfa_theta_spearman <- function(S, bounds = "wide") {
  p <- ncol(S)
  out <- numeric(p)
  R <- cov2cor(S)
  for (p.idx in seq_len(p)) {
    var.p <- R[p.idx, p.idx]
    x <- R[, p.idx][-p.idx]
    aa <- lav_matrix_vech(tcrossprod(x), diagonal = FALSE)
    ss <- lav_matrix_vech(R[-p.idx, -p.idx, drop = FALSE], diagonal = FALSE)
    h2 <- mean(aa / ss) # communaliteit
    if (bounds == "standard") {
      h2[h2 < 0] <- 0
      h2[h2 > 1] <- 1
    } else if (bounds == "wide") {
      h2[h2 < -0.05] <- -0.05 # correponds to lower bound ov.var "wide"
      h2[h2 > +1.20] <- +1.20 # correponds to upper bound ov.var "wide"
    }
    out[p.idx] <- (1 - h2) * S[p.idx, p.idx]
  }
  out
}

# user-visible routine to
# compute polychoric/polyserial/... correlations
#
# YR 17 Sept 2013
#
# - YR 26 Nov 2013: big change - make it a wrapper around lavaan()
#                   estimator = "none" means two.step (starting values)

lav_object_cor <- function(object,
                   # lav.data options
                   ordered = NULL,
                   group = NULL,
                   missing = "listwise",
                   ov.names.x = NULL,
                   sampling.weights = NULL,
                   # lavaan options
                   se = "none",
                   test = "none",
                   estimator = "two.step",
                   baseline = FALSE,
                   # other options (for lavaan)
                   ...,
                   cor.smooth = FALSE,
                   cor.smooth.tol = 1e-04, # was 1e-06 in <0.6-14
                   output = "cor") {
  # shortcut if object = lavaan object
  if (inherits(object, "lavaan")) {
    # check object
    object <- lav_object_check_version(object)
    dotdotdot <- list(...)
    if (length(dotdotdot) > 0L) {
      for (j in seq_along(dotdotdot)) {
        lav_msg_warn(gettextf(
          "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
          "function lav_object_cor for lavaan-object")
        )
      }
    }
    out <- lav_object_cor_output(object, output = output)
    return(out)
  }

  # check estimator
  estimator <- tolower(estimator)
  if (estimator %in% c("two.step", "two.stage")) {
    estimator <- "none"
  }

  # se?
  se <- tolower(se)
  output <- tolower(output)
  if (se != "none") {
    if (output %in% c("cor", "cov", "sampstat", "th", "thresholds")) {
      lav_msg_warn(gettext("argument `se' is ignored since standard errors
                           are not needed for the requested `output'"))
      se <- "none"
    }
  }

  # extract sampling.weights.normalization from dots (for lav_lavdata() call)
  dots <- list(...)
  sampling.weights.normalization <- "total"
  if (!is.null(dots$sampling.weights.normalization)) {
    sampling.weights.normalization <- dots$sampling.weights.normalization
  }


  # check object class
  if (inherits(object, "lavData")) {
    lav.data <- object
  } else if (inherits(object, "data.frame") ||
    inherits(object, "matrix")) {
    object <- as.data.frame(object)
    NAMES <- names(object)
    if (!is.null(group)) {
      NAMES <- NAMES[-match(group, NAMES)]
    }
    if (!is.null(sampling.weights)) {
      NAMES <- NAMES[-match(sampling.weights, NAMES)]
    }
    if (is.logical(ordered)) {
      ordered.flag <- ordered
      if (ordered.flag) {
        ordered <- NAMES
        if (length(ov.names.x) > 0L) {
          ordered <- ordered[-which(ordered %in% ov.names.x)]
        }
      } else {
        ordered <- character(0L)
      }
    } else if (is.null(ordered)) {
      ordered <- character(0L)
    } else if (!is.character(ordered)) {
      lav_msg_stop(gettext("ordered argument must be a character vector"))
    } else if (length(ordered) == 1L && nchar(ordered) == 0L) {
      ordered <- character(0L)
    } else {
      # check if all names in "ordered" occur in the dataset?
      missing.idx <- which(!ordered %in% NAMES)
      if (length(missing.idx) > 0L) {
        lav_msg_warn(gettextf(
          "ordered variable(s): %s could not be found
          in the data and will be ignored",
          lav_msg_view(ordered[missing.idx])))
      }
    }
    lav.data <- lav_lavdata(
      data = object, group = group,
      ov.names = NAMES, ordered = ordered,
      sampling.weights = sampling.weights,
      ov.names.x = ov.names.x,
      lavoptions = list(
        missing = missing,
        sampling.weights.normalization = sampling.weights.normalization
      )
    )
  } else {
    lav_msg_stop(gettext("lav_object_cor can not handle objects of class"),
      paste(class(object), collapse = " ")
    )
  }

  # set default estimator if se != "none"
  categorical <- any(lav.data@ov$type == "ordered")
  if (se != "none" && estimator == "none") {
    if (categorical) {
      estimator <- "WLSMV"
    } else {
      estimator <- "ML"
    }
  }

  # extract more partable options from dots
  meanstructure <- FALSE
  fixed.x <- FALSE
  mimic <- "lavaan"
  conditional.x <- FALSE
  if (!is.null(dots$meanstructure)) {
    meanstructure <- dots$meanstructure
  }
  if (lav.data@ngroups > 1L || categorical || tolower(missing) %in% c("ml", "fiml", "direct")) {
    meanstructure <- TRUE
  }
  if (!is.null(dots$fixed.x)) {
    fixed.x <- dots$fixed.x
  }
  if (!is.null(dots$mimic)) {
    mimic <- dots$mimic
  }
  if (!is.null(dots$conditional.x)) {
    conditional.x <- dots$conditional.x
  }

  # override, only for backwards compatibility (eg moments() in JWileymisc)
  # if(missing %in% c("ml", "fiml")) {
  #    meanstructure = TRUE
  # }

  # generate partable for unrestricted model
  PT.un <-
    lav_partable_unrestricted(
      lavobject = NULL,
      lavdata = lav.data,
      lavoptions = list(
        meanstructure = meanstructure,
        fixed.x = fixed.x,
        conditional.x = conditional.x,
        # sampling.weights.normalization = sampling.weights.normalization,
        group.w.free = FALSE,
        missing = missing,
        estimator = estimator,
        mimic = mimic
      ),
      sample.cov = NULL,
      sample.mean = NULL,
      sample.th = NULL
    )


  FIT <- lavaan(
    slotParTable = PT.un, slotData = lav.data,
    model.type = "unrestricted",
    missing = missing,
    baseline = baseline, h1 = TRUE, # must be TRUE!
    se = se, test = test, estimator = estimator, ...
  )

  out <- lav_object_cor_output(FIT, output = output)

  # smooth correlation matrix? (only if output = "cor")
  if (output == "cor" && cor.smooth) {
    tmp.attr <- attributes(out)
    out <- cov2cor(lav_matrix_symmetric_force_pd(out, tol = cor.smooth.tol))
    # we lost most of the attributes
    attributes(out) <- tmp.attr
  }

  out
}
lavCor <- lav_object_cor  # synonym #nolint

lav_object_cor_output <- function(object, output = "cor") {
  # check output
  if (output %in% c("cor", "cov")) {
    out <- lavInspect(object, "sampstat")
    if (object@Data@ngroups == 1L) {
      if (object@Model@conditional.x) {
        out <- out$res.cov
      } else {
        out <- out$cov
      }
      if (output == "cor") {
        out <- cov2cor(out)
      }
    } else {
      if (object@Model@conditional.x) {
        out <- lapply(out, "[[", "res.cov")
      } else {
        out <- lapply(out, "[[", "cov")
      }
      if (output == "cor") {
        out <- lapply(out, cov2cor)
      }
    }
  } else if (output %in% c("th", "thresholds")) {
    out <- lavInspect(object, "sampstat")
    if (object@Data@ngroups == 1L) {
      if (object@Model@conditional.x) {
        out <- out$res.th
      } else {
        out <- out$th
      }
    } else {
      if (object@Model@conditional.x) {
        out <- lapply(out, "[[", "res.th")
      } else {
        out <- lapply(out, "[[", "th")
      }
    }
  } else if (output %in% c("sampstat")) {
    out <- lavInspect(object, "sampstat")
  } else if (output %in% c(
    "parameterEstimates", "pe",
    "parameterestimates", "est"
  )) {
    out <- standardizedSolution(object)
  } else {
    out <- object
  }

  out
}

# inspect a lavaanList object

lav_lavaanlist_inspect <- function(object, what = "free", ...) {
  dotdotdot <- list(...)
  if (length(dotdotdot) > 0L) {
    for (j in seq_along(dotdotdot)) {
      lav_msg_warn(gettextf(
        "Unknown argument %s for %s", sQuote(names(dotdotdot)[j]),
        sQuote("inspect"))
      )
    }
  }
  lavListInspect(
    object = object,
    what = what,
    add.labels = TRUE,
    add.class = TRUE,
    drop.list.single.group = TRUE
  )
}

# the `tech' version: no labels, full matrices, ... for further processing
lav_lavaanlist_lavtech <- function(object,
                               what = "free",
                               add.labels = FALSE,
                               add.class = FALSE,
                               list.by.group = FALSE,
                               drop.list.single.group = FALSE) {
  lavListInspect(
    object = object, what = what,
    add.labels = add.labels, add.class = add.class,
    list.by.group = list.by.group,
    drop.list.single.group = drop.list.single.group
  )
}

lavListTech <- function(object,
                        what = "free",
                        add.labels = FALSE,
                        add.class = FALSE,
                        list.by.group = FALSE,
                        drop.list.single.group = FALSE) {
  lavListInspect(
    object = object, what = what,
    add.labels = add.labels, add.class = add.class,
    list.by.group = list.by.group,
    drop.list.single.group = drop.list.single.group
  )
}

# just in case some uses lavInspect on a lavaanList object
lav_lavaanlist_lavinspect <- function(object,
                                  what = "free",
                                  add.labels = TRUE,
                                  add.class = TRUE,
                                  list.by.group = TRUE,
                                  drop.list.single.group = TRUE) {
  lavListInspect(
    object = object, what = what,
    add.labels = add.labels, add.class = add.class,
    list.by.group = list.by.group,
    drop.list.single.group = drop.list.single.group
  )
}

lavListInspect <- function(object,
                           what = "free",
                           add.labels = TRUE,
                           add.class = TRUE,
                           list.by.group = TRUE,
                           drop.list.single.group = TRUE) {
  # object must inherit from class lavaanList
  stopifnot(inherits(object, "lavaanList"))

  # only a single argument
  if (length(what) > 1) {
    lav_msg_stop(gettext(
      "`what' arguments contains multiple arguments; only one is allowed"))
  }

  # be case insensitive
  what <- tolower(what)


  #### model matrices, with different contents ####
  if (what == "free") {
    lav_lavaanlist_inspect_modelmatrices(object,
      what = "free",
      type = "free", add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group
    )
  } else if (what == "partable" || what == "user") {
    lav_lavaanlist_inspect_modelmatrices(object,
      what = "free",
      type = "partable", add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group
    )
  } else if (what == "start" || what == "starting.values") {
    lav_lavaanlist_inspect_modelmatrices(object,
      what = "start",
      add.labels = add.labels, add.class = add.class,
      list.by.group = list.by.group,
      drop.list.single.group = drop.list.single.group
    )


    #### parameter table ####
  } else if (what == "list") {
    parTable(object)

    #### data + missingness ####
  } else if (what == "ngroups") {
    object@Data@ngroups
  } else if (what == "group") {
    object@Data@group
  } else if (what == "cluster") {
    object@Data@cluster
  } else if (what == "nlevels") {
    object@Data@nlevels
  } else if (what == "nclusters") {
    lav_object_inspect_cluster_info(object,
      level = 2L,
      what = "nclusters",
      drop.list.single.group = drop.list.single.group
    )
  } else if (what == "ncluster.size") {
    lav_object_inspect_cluster_info(object,
      level = 2L,
      what = "ncluster.size",
      drop.list.single.group = drop.list.single.group
    )
  } else if (what == "cluster.size") {
    lav_object_inspect_cluster_info(object,
      level = 2L,
      what = "cluster.size",
      drop.list.single.group = drop.list.single.group
    )
  } else if (what == "cluster.id") {
    lav_object_inspect_cluster_info(object,
      level = 2L,
      what = "cluster.id",
      drop.list.single.group = drop.list.single.group
    )
  } else if (what == "cluster.idx") {
    lav_object_inspect_cluster_info(object,
      level = 2L,
      what = "cluster.idx",
      drop.list.single.group = drop.list.single.group
    )
  } else if (what == "cluster.label") {
    lav_object_inspect_cluster_info(object,
      level = 2L,
      what = "cluster.label",
      drop.list.single.group = drop.list.single.group
    )
  } else if (what == "cluster.sizes") {
    lav_object_inspect_cluster_info(object,
      level = 2L,
      what = "cluster.sizes",
      drop.list.single.group = drop.list.single.group
    )
  } else if (what == "average.cluster.size") {
    lav_object_inspect_cluster_info(object,
      level = 2L,
      what = "average.cluster.size",
      drop.list.single.group = drop.list.single.group
    )
  } else if (what == "ordered") {
    object@Data@ordered
  } else if (what == "group.label") {
    object@Data@group.label
  } else if (what == "level.label") {
    object@Data@level.label
  } else if (what == "nobs") { # only for original!
    unlist(object@Data@nobs)
  } else if (what == "norig") { # only for original!
    unlist(object@Data@norig)
  } else if (what == "ntotal") { # only for original!
    sum(unlist(object@Data@nobs))

    #### from the model object (but stable) over datasets? ####
  } else if (what == "th.idx") {
    lav_lavaanlist_inspect_th_idx(object,
      add.labels = add.labels, add.class = add.class,
      drop.list.single.group = drop.list.single.group
    )


    #### meanstructure, categorical ####
  } else if (what == "meanstructure") {
    object@Model@meanstructure
  } else if (what == "categorical") {
    object@Model@categorical
  } else if (what == "fixed.x") {
    object@Model@fixed.x
  } else if (what == "parameterization") {
    object@Model@parameterization

    # options
  } else if (what == "options" || what == "lavoptions") {
    object@Options

    # call
  } else if (what == "call") {
    as.list(object@call)

    #### not found ####
  } else {
    lav_msg_stop(gettextf(
      "unknown `what' argument in inspect function: `%s'", what))
  }
}


lav_lavaanlist_inspect_start <- function(object) {
  # from 0.5-19, they are in the partable
  if (!is.null(object@ParTable$start)) {
    OUT <- object@ParTable$start
  } else {
    # in < 0.5-19, we should look in @Fit@start
    OUT <- object@Fit@start
  }

  OUT
}

lav_lavaanlist_inspect_modelmatrices <- function(
    object, what = "free",
    type = "free", add.labels = FALSE, add.class = FALSE,
    list.by.group = FALSE,
    drop.list.single.group = FALSE) {
  GLIST <- object@Model@GLIST

  for (mm in 1:length(GLIST)) {
    if (add.labels) {
      dimnames(GLIST[[mm]]) <- object@Model@dimNames[[mm]]
    }

    if (what == "free") {
      # fill in free parameter counts
      if (type == "free") {
        m.el.idx <- object@Model@m.free.idx[[mm]]
        x.el.idx <- object@Model@x.free.idx[[mm]]
        # } else if(type == "unco") {
        #    m.el.idx <- object@Model@m.unco.idx[[mm]]
        #    x.el.idx <- object@Model@x.unco.idx[[mm]]
      } else if (type == "partable") {
        m.el.idx <- object@Model@m.user.idx[[mm]]
        x.el.idx <- object@Model@x.user.idx[[mm]]
      } else {
        lav_msg_stop(gettextf("unknown type argument: %s", type))
      }
      # erase everything
      GLIST[[mm]][, ] <- 0.0
      GLIST[[mm]][m.el.idx] <- x.el.idx
    } else if (what == "start") {
      # fill in starting values
      m.user.idx <- object@Model@m.user.idx[[mm]]
      x.user.idx <- object@Model@x.user.idx[[mm]]
      START <- lav_lavaanlist_inspect_start(object)
      GLIST[[mm]][m.user.idx] <- START[x.user.idx]
    }

    # class
    if (add.class) {
      if (object@Model@isSymmetric[mm]) {
        class(GLIST[[mm]]) <- c("lavaan.matrix.symmetric", "matrix")
      } else {
        class(GLIST[[mm]]) <- c("lavaan.matrix", "matrix")
      }
    }
  }

  # try to reflect `equality constraints'
  con.flag <- FALSE
  if (what == "free" && object@Model@eq.constraints) {
    # extract constraints from parameter table
    PT <- parTable(object)
    CON <- PT[PT$op %in% c("==", "<", ">"), c("lhs", "op", "rhs")]
    rownames(CON) <- NULL

    # replace 'labels' by parameter numbers
    ID <- lav_partable_constraints_label_id(PT)
    LABEL <- names(ID)
    for (con in 1:nrow(CON)) {
      # lhs
      LHS.labels <- all.vars(as.formula(paste("~", CON[con, "lhs"])))

      if (length(LHS.labels) > 0L) {
        # par id
        LHS.freeid <- ID[match(LHS.labels, LABEL)]

        # substitute
        tmp <- CON[con, "lhs"]
        for (pat in 1:length(LHS.labels)) {
          tmp <- sub(LHS.labels[pat], LHS.freeid[pat], tmp)
        }
        CON[con, "lhs"] <- tmp
      }

      # rhs
      RHS.labels <- all.vars(as.formula(paste("~", CON[con, "rhs"])))

      if (length(RHS.labels) > 0L) {
        # par id
        RHS.freeid <- ID[match(RHS.labels, LABEL)]
        # substitute
        tmp <- CON[con, "rhs"]
        for (pat in 1:length(RHS.labels)) {
          tmp <- sub(RHS.labels[pat], RHS.freeid[pat], tmp)
        }
        CON[con, "rhs"] <- tmp
      }
    } # con

    # add this info at the top
    # GLIST <- c(constraints = list(CON), GLIST)
    # no, not a good idea, it does not work with list.by.group

    # add it as a 'header' attribute?
    attr(CON, "header") <- "Note: model contains equality constraints:"
    con.flag <- TRUE
  }

  # should we group them per group?
  if (list.by.group) {
    lavmodel <- object@Model
    nmat <- lavmodel@nmat

    OUT <- vector("list", length = object@Data@ngroups)
    for (g in 1:object@Data@ngroups) {
      # which mm belong to group g?
      mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g]
      mm.names <- names(GLIST[mm.in.group])

      OUT[[g]] <- GLIST[mm.in.group]
    }

    if (object@Data@ngroups == 1L && drop.list.single.group) {
      OUT <- OUT[[1]]
    } else {
      if (length(object@Data@group.label) > 0L) {
        names(OUT) <- unlist(object@Data@group.label)
      }
    }
  } else {
    OUT <- GLIST
  }

  # header
  if (con.flag) {
    attr(OUT, "header") <- CON
  }

  # lavaan.list
  if (add.class) {
    class(OUT) <- c("lavaan.list", "list")
  }

  OUT
}

lav_lavaanlist_inspect_th_idx <- function(
    object,
    add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
  # thresholds idx -- usually, we get it from SampleStats
  # but fortunately, there is a copy in Model, but no names...
  OUT <- object@Model@th.idx

  # nblocks
  nblocks <- length(OUT)

  # labels + class
  for (b in seq_len(nblocks)) {
    # if(add.labels && length(OUT[[b]]) > 0L) {
    #    names(OUT[[b]]) <- object@SampleStats@th.names[[b]]
    # }
    if (add.class && !is.null(OUT[[b]])) {
      class(OUT[[b]]) <- c("lavaan.vector", "numeric")
    }
  }

  if (nblocks == 1L && drop.list.single.group) {
    OUT <- OUT[[1]]
  } else {
    if (object@Data@nlevels == 1L &&
      length(object@Data@group.label) > 0L) {
      names(OUT) <- unlist(object@Data@group.label)
    } else if (object@Data@nlevels > 1L &&
      length(object@Data@group.label) == 0L) {
      names(OUT) <- object@Data@level.label
    }
  }

  OUT
}

# generate lavaan model syntax from a list of model matrices
#
# YR -- 4 Dec 2021
#
# - currently for a single group/level only
# - continuous setting only; the model matrices are LAMBDA, PSI, THETA and
#   optionally BETA
#
# we return a single string

lav_syntax_mlist <- function(MLIST, ov.prefix = "y", lv.prefix = "f",
                             include.values = TRUE) {
  # model matrices
  LAMBDA <- MLIST$lambda
  THETA <- MLIST$theta
  PSI <- MLIST$psi
  BETA <- MLIST$beta

  # check prefix
  if (ov.prefix == lv.prefix) {
    lav_msg_stop(gettext("ov.prefix can not be the same as lv.prefix"))
  }

  header <- "# syntax generated by lav_syntax_mlist()"

  # LAMBDA
  if (!is.null(LAMBDA)) {
    IDXV <- row(LAMBDA)[(LAMBDA != 0)]
    IDXF <- col(LAMBDA)[(LAMBDA != 0)]
    # lambda.txt <- character(nfactors)
    # for(f in seq_len(nfactors)) {
    #      var.idx <- which(LAMBDA[,f] != 0.0)
    #      lambda.vals <- LAMBDA[var.idx, f]
    #      lambda.txt[f] <- paste( paste0(lv.prefix, f), "=~",
    #                              paste(lambda.vals, "*",
    #                              paste0(ov.prefix, var.idx),
    #                              sep = "", collapse = " + ") )
    # }
    nel <- length(IDXF)
    lambda.txt <- character(nel)
    for (i in seq_len(nel)) {
      if (include.values) {
        lambda.txt[i] <- paste0(
          paste0(lv.prefix, IDXF[i]), " =~ ",
          LAMBDA[IDXV[i], IDXF[i]], "*",
          paste0(ov.prefix, IDXV[i])
        )
      } else {
        lambda.txt[i] <- paste0(
          paste0(lv.prefix, IDXF[i]), " =~ ",
          paste0(ov.prefix, IDXV[i])
        )
      }
    }
  } else {
    lambda.txt <- character(0L)
  }

  # THETA
  if (!is.null(THETA)) {
    IDX1 <- row(THETA)[(THETA != 0) & upper.tri(THETA, diag = TRUE)]
    IDX2 <- col(THETA)[(THETA != 0) & upper.tri(THETA, diag = TRUE)]
    nel <- length(IDX1)
    theta.txt <- character(nel)
    for (i in seq_len(nel)) {
      if (include.values) {
        theta.txt[i] <- paste0(
          paste0(ov.prefix, IDX1[i]), " ~~ ",
          THETA[IDX1[i], IDX2[i]], "*",
          paste0(ov.prefix, IDX2[i])
        )
      } else {
        theta.txt[i] <- paste0(
          paste0(ov.prefix, IDX1[i]), " ~~ ",
          paste0(ov.prefix, IDX2[i])
        )
      }
    }
  } else {
    theta.txt <- character(0L)
  }

  # PSI
  if (!is.null(PSI)) {
    IDX1 <- row(PSI)[(PSI != 0) & upper.tri(PSI, diag = TRUE)]
    IDX2 <- col(PSI)[(PSI != 0) & upper.tri(PSI, diag = TRUE)]
    nel <- length(IDX1)
    psi.txt <- character(nel)
    for (i in seq_len(nel)) {
      if (include.values) {
        psi.txt[i] <- paste0(
          paste0(lv.prefix, IDX1[i]), " ~~ ",
          PSI[IDX1[i], IDX2[i]], "*",
          paste0(lv.prefix, IDX2[i])
        )
      } else {
        psi.txt[i] <- paste0(
          paste0(lv.prefix, IDX1[i]), " ~~ ",
          paste0(lv.prefix, IDX2[i])
        )
      }
    }
  } else {
    psi.txt <- character(0L)
  }

  # BETA
  if (!is.null(BETA)) {
    IDX1 <- row(BETA)[(BETA != 0)]
    IDX2 <- col(BETA)[(BETA != 0)]
    nel <- length(IDX1)
    beta.txt <- character(nel)
    for (i in seq_len(nel)) {
      if (include.values) {
        beta.txt[i] <- paste0(
          paste0(lv.prefix, IDX1[i]), " ~ ",
          BETA[IDX1[i], IDX2[i]], "*",
          paste0(lv.prefix, IDX2[i])
        )
      } else {
        beta.txt[i] <- paste0(
          paste0(lv.prefix, IDX1[i]), " ~ ",
          paste0(lv.prefix, IDX2[i])
        )
      }
    }
  } else {
    beta.txt <- character(0L)
  }

  # assemble
  syntax <- paste(c(header, lambda.txt, theta.txt, psi.txt, beta.txt, ""),
    collapse = "\n"
  )

  syntax
}

# deprecated: only kept in order to avoid some older packages
lav_model_fit <- function(lavpartable = NULL,
                          lavmodel = NULL,
                          lavimplied = NULL,
                          x = NULL,
                          VCOV = NULL,
                          TEST = NULL) {
  stopifnot(is.list(lavpartable), inherits(lavmodel, "lavModel"))

  # extract information from 'x'
  iterations <- attr(x, "iterations")
  converged <- attr(x, "converged")
  fx <- attr(x, "fx")
  fx.group <- attr(fx, "fx.group")
  if (!is.null(attr(fx, "logl.group"))) {
    logl.group <- attr(fx, "logl.group")
    logl <- sum(logl.group)
  } else {
    logl.group <- as.numeric(NA)
    logl <- as.numeric(NA)
  }
  # print(fx.group)
  control <- attr(x, "control")
  attributes(fx) <- NULL
  x.copy <- x # we are going to change it (remove attributes)
  attributes(x.copy) <- NULL
  est <- lav_model_get_parameters(lavmodel = lavmodel, type = "user")

  # did we compute standard errors?
  if (is.null(lavpartable$se)) {
    if (is.null(VCOV)) {
      se <- rep(as.numeric(NA), lavmodel@nx.user)
      se[lavpartable$free == 0L] <- 0
    } else {
      se <- lav_model_vcov_se(
        lavmodel = lavmodel,
        lavpartable = lavpartable,
        VCOV = VCOV,
        BOOT = attr(VCOV, "BOOT.COEF")
      )
    }
  } else {
    se <- as.numeric(lavpartable$se) # could be logical NA
  }

  # did we compute test statistics
  if (is.null(TEST)) {
    test <- list()
  } else {
    test <- TEST
  }

  # for convenience: compute lavmodel-implied Sigma and Mu
  if (is.null(lavimplied) || length(lavimplied) == 0L) {
    implied <- lav_model_implied(lavmodel)
  } else {
    implied <- lavimplied
  }

  # if bootstrapped parameters, add attr to 'est'
  if (!is.null(attr(VCOV, "BOOT.COEF"))) {
    attr(est, "BOOT.COEF") <- attr(VCOV, "BOOT.COEF")
  }

  # partrace?
  if (!is.null(attr(x, "partrace"))) {
    PARTRACE <- attr(x, "partrace")
  } else {
    PARTRACE <- matrix(0, 0L, 0L)
  }

  new("Fit",
    npar       = max(lavpartable$free),
    x          = x.copy,
    partrace   = PARTRACE,
    start      = lavpartable$start, # needed? (package stremo!)
    est        = est, # at least 5 packages!!
    se         = se,
    fx         = fx,
    fx.group   = fx.group,
    logl       = logl,
    logl.group = logl.group,
    iterations = iterations,
    converged  = converged,
    control    = control,
    Sigma.hat  = if (lavmodel@conditional.x) implied$res.cov else implied$cov,
    Mu.hat     = if (lavmodel@conditional.x) implied$res.int else implied$mean,
    TH         = if (lavmodel@conditional.x) implied$res.th else implied$th,
    test       = test
  )
}

lav_samplestats_wls_obs <- function(mean.g, cov.g, var.g,
                                    th.g, th.idx.g,
                                    res.int.g, res.cov.g, res.var.g, res.th.g,
                                    res.slopes.g,
                                    group.w.g,
                                    categorical = FALSE,
                                    conditional.x = FALSE,
                                    meanstructure = FALSE,
                                    correlation = FALSE,
                                    slopestructure = FALSE,
                                    group.w.free = FALSE) {
  # WLS.obs
  if (categorical) {
    # order of elements is important here:
    # 1. thresholds + (negative) means (interleaved)
    # 2. slopes (if any)
    # 3. variances (if any)
    # 4. covariance matrix (no diagonal!)

    # NOTE: prior to 0.5-17, we had this:
    # TH[ov.types == "numeric"] <- -1*TH[ov.types == "numeric"]
    # which is WRONG if we have more than one threshold per variable
    # (thanks to Sacha Epskamp for spotting this!)
    if (conditional.x) {
      TH <- res.th.g
      TH[th.idx.g == 0] <- -1 * TH[th.idx.g == 0]

      nvar <- length(res.var.g)
      num.idx <- which(!seq_len(nvar) %in% th.idx.g)

      WLS.obs <- c(
        TH,
        lav_matrix_vec(res.slopes.g),
        res.var.g[num.idx],
        lav_matrix_vech(res.cov.g, diagonal = FALSE)
      )
    } else {
      TH <- th.g
      TH[th.idx.g == 0] <- -1 * TH[th.idx.g == 0]

      nvar <- length(var.g)
      num.idx <- which(!seq_len(nvar) %in% th.idx.g)

      WLS.obs <- c(
        TH,
        var.g[num.idx],
        lav_matrix_vech(cov.g, diagonal = FALSE)
      )
    }
  } else {
    # CONTINUOUS:
    DIAG <- TRUE
    if (correlation) {
      DIAG <- FALSE
    }
    if (conditional.x) {
      if (meanstructure) {
        if (slopestructure) {
          # order = vec(Beta), where first row are intercepts
          # cbind(res.int, res.slopes) is t(Beta)
          # so we need vecr
          WLS.obs <- c(
            lav_matrix_vecr(cbind(
              res.int.g,
              res.slopes.g
            )),
            lav_matrix_vech(res.cov.g, diagonal = DIAG)
          )
        } else {
          WLS.obs <- c(
            res.int.g,
            lav_matrix_vech(res.cov.g, diagonal = DIAG)
          )
        }
      } else {
        if (slopestructure) {
          WLS.obs <- c(
            lav_matrix_vecr(res.slopes.g),
            lav_matrix_vech(res.cov.g, diagonal = DIAG)
          )
        } else {
          WLS.obs <- lav_matrix_vech(res.cov.g, diagonal = DIAG)
        }
      }
    } else {
      if (meanstructure) {
        WLS.obs <- c(
          mean.g,
          lav_matrix_vech(cov.g, diagonal = DIAG)
        )
      } else {
        WLS.obs <- lav_matrix_vech(cov.g, diagonal = DIAG)
      }
    }
  }

  # group.w.free?
  if (group.w.free) {
    WLS.obs <- c(group.w.g, WLS.obs)
  }

  WLS.obs
}

# SAM step 2: estimate structural part

lav_sam_step2 <- function(STEP1 = NULL, FIT = NULL,
                          sam.method = "local", struc.args = list()) {
  lavoptions <- FIT@Options
  lavpta <- FIT@pta
  nlevels <- lavpta$nlevels
  PT <- STEP1$PT

  # Gamma available?
  gamma.flag <- FALSE
  if (sam.method %in% c("local", "fsr", "cfsr") &&
      !is.null(STEP1$Gamma.eta[[1]])) {
    gamma.flag <- TRUE
  }

  LV.names <- unique(unlist(FIT@pta$vnames$lv.regular))

  # adjust options
  lavoptions.PA <- lavoptions
  if (lavoptions.PA$se == "naive") {
    lavoptions.PA$se <- "standard"
  } else if (gamma.flag) {
    lavoptions.PA$se <- "robust.sem"
    lavoptions.PA$test <- "satorra.bentler"
  } else {
    # twostep or none -> none
    lavoptions.PA$se <- "none"
  }
  # lavoptions.PA$fixed.x <- TRUE # may be false if indicator is predictor
  if (!lavoptions.PA$conditional.x) {
    lavoptions.PA$fixed.x <- FALSE # until we fix this...
  }
  lavoptions.PA$categorical <- FALSE
  lavoptions.PA$.categorical <- FALSE
  lavoptions.PA$rotation <- "none"
  lavoptions.PA <- modifyList(lavoptions.PA, struc.args)

  if (gamma.flag) {
    lavoptions.PA$check.vcov <- FALSE # always non-pd if interactions + fixed.x = FALSE
  }

  # override, no matter what
  lavoptions.PA$do.fit <- TRUE

  if (sam.method %in% c("local", "fsr", "cfsr")) {
    lavoptions.PA$missing <- "listwise"
    lavoptions.PA$sample.cov.rescale <- FALSE
    # lavoptions.PA$baseline <- FALSE
    # lavoptions.PA$h1 <- FALSE
    # lavoptions.PA$implied <- FALSE
    lavoptions.PA$loglik <- FALSE
  } else {
    lavoptions.PA$h1 <- FALSE
    # lavoptions.PA$implied <- FALSE
    lavoptions.PA$loglik <- FALSE
  }


  # construct PTS
  if (sam.method %in% c("local", "fsr", "cfsr")) {
    # extract structural part
    PTS <- lav_partable_subset_structural_model(PT,
      add.idx = TRUE,
      add.exo.cov = TRUE,
      fixed.x = lavoptions.PA$fixed.x,
      conditional.x = lavoptions.PA$conditional.x,
      free.fixed.var = TRUE,
      meanstructure = lavoptions.PA$meanstructure
    )

    # any 'extra' parameters: not (free) in PT, but free in PTS (user == 3)
    #  - fixed.x in PT, but fixed.x = FALSE is PTS
    #  - fixed-to-zero interceps in PT, but free in PTS
    #  - add.exo.cov: absent/fixed-to-zero in PT, but add/free in PTS
    extra.id <- which(PTS$user == 3L)

    # remove est/se/start columns
    PTS$est <- NULL
    PTS$se <- NULL
    PTS$start <- NULL

    if (nlevels > 1L) {
      PTS$level <- NULL
      PTS$group <- NULL
      PTS$group <- PTS$block
      NOBS <- FIT@Data@Lp[[1]]$nclusters
    } else {
      NOBS <- FIT@Data@nobs
    }

    # if meanstructure, 'free' user=0 intercepts?
    # if (lavoptions.PA$meanstructure) {
    #   extra.int.idx <- which(PTS$op == "~1" & PTS$user == 0L &
    #     PTS$free == 0L &
    #     PTS$exo == 0L) # needed?
    #   if (length(extra.int.idx) > 0L) {
    #     PTS$free[extra.int.idx] <- 1L
    #     PTS$ustart[extra.int.idx] <- as.numeric(NA)
    #     PTS$free[PTS$free > 0L] <-
    #       seq_len(length(PTS$free[PTS$free > 0L]))
    #     PTS$user[extra.int.idx] <- 3L
    #   }
    # } else {
    #   extra.int.idx <- integer(0L)
    # }
    # extra.id <- c(extra.id, extra.int.idx)

    reg.idx <- attr(PTS, "idx")
    attr(PTS, "idx") <- NULL
  } else {
    # global SAM

    # the measurement model parameters now become fixed ustart values
    PT$ustart[PT$free > 0] <- PT$est[PT$free > 0]

    reg.idx <- lav_partable_subset_structural_model(
      PT = PT,
      idx.only = TRUE
    )

    # remove 'exogenous' factor variances (if any) from reg.idx
    lv.names.x <- LV.names[LV.names %in% unlist(lavpta$vnames$eqs.x) &
      !LV.names %in% unlist(lavpta$vnames$eqs.y)]
    if ((lavoptions.PA$fixed.x || lavoptions.PA$std.lv) &&
        length(lv.names.x) > 0L) {
      var.idx <- which(PT$lhs %in% lv.names.x &
        PT$op == "~~" &
        PT$lhs == PT$rhs)
      rm.idx <- which(reg.idx %in% var.idx)
      if (length(rm.idx) > 0L) {
        reg.idx <- reg.idx[-rm.idx]
      }
    }

    # adapt parameter table for structural part
    PTS <- PT

    # remove constraints we don't need
    con.idx <- which(PTS$op %in% c("==", "<", ">", ":="))
    if (length(con.idx) > 0L) {
      needed.idx <- which(con.idx %in% reg.idx)
      if (length(needed.idx) > 0L) {
        con.idx <- con.idx[-needed.idx]
      }
      if (length(con.idx) > 0L) {
        PTS <- as.data.frame(PTS, stringsAsFactors = FALSE)
        PTS <- PTS[-con.idx, ]
      }
    }
    PTS$est <- NULL
    PTS$se <- NULL

    # 'fix' step 1 parameters
    PTS$free[!PTS$id %in% reg.idx & PTS$free > 0L] <- 0L

    # but free up residual variances if fixed (eg std.lv = TRUE) (new in 0.6-20)
    var.idx <- reg.idx[which(PT$free[reg.idx] == 0L &
                             PT$user[reg.idx] != 1L &
                             PT$op[reg.idx] == "~~")] # FIXME: more?
    PTS$free[var.idx] <- max(PTS$free) + seq_len(length(var.idx))

    # set 'ustart' values for free FIT.PA parameter to NA
    PTS$ustart[PTS$free > 0L] <- as.numeric(NA)

    PTS <- lav_partable_complete(PTS)

    extra.id <- extra.int.idx <- integer(0L)
  } # global

  # fit structural model
  if (lav_verbose()) {
    cat("Fitting the structural part ... \n")
  }
  if (sam.method %in% c("local", "fsr", "cfsr")) {
    if (gamma.flag) {
      NACOV <- STEP1$Gamma.eta
      ov.order <- "data"
    } else {
      NACOV <- NULL
      ov.order <- "model"
    }
    FIT.PA <- lavaan::lavaan(PTS,
      sample.cov  = STEP1$VETA,
      sample.mean = STEP1$EETA,
      sample.nobs = NOBS,
      NACOV       = NACOV,
      slotOptions = lavoptions.PA,
      verbose     = FALSE
    )
  } else {
    FIT.PA <- lavaan::lavaan(
      model = PTS,
      slotData = FIT@Data,
      slotSampleStats = FIT@SampleStats,
      slotOptions = lavoptions.PA,
      verbose = FALSE
    )
  }
  if (lav_verbose()) {
    cat("Fitting the structural part ... done.\n")
  }

  # which parameters from PTS do we wish to fill in:
  # - all 'free' parameters
  # - :=, <, > (if any)
  # - and NOT element with user=3 (add.exo.cov = TRUE, extra.int.idx)
  pts.idx <- which((PTS$free > 0L | (PTS$op %in% c(":=", "<", ">"))) &
    !PTS$user == 3L)

  # find corresponding rows in PT
  PTS2 <- as.data.frame(PTS, stringsAsFactors = FALSE)
  pt.idx <- lav_partable_map_id_p1_in_p2(PTS2[pts.idx, ], PT,
    exclude.nonpar = FALSE
  )
  # fill in
  PT$est[pt.idx] <- FIT.PA@ParTable$est[pts.idx]

  # create step2.free.idx
  p2.idx <- seq_len(length(PT$lhs)) %in% pt.idx & PT$free > 0 # no def!
  step2.free.idx <- STEP1$PT.free[p2.idx]

  # add 'step' column in PT
  PT$step <- rep(1L, length(PT$lhs))
  PT$step[seq_len(length(PT$lhs)) %in% reg.idx] <- 2L

  STEP2 <- list(
    FIT.PA = FIT.PA, PT = PT, reg.idx = reg.idx,
    step2.free.idx = step2.free.idx, extra.id = extra.id,
    pt.idx = pt.idx, pts.idx = pts.idx
  )

  STEP2
}

# compare two nested models, by default using the chi-square
# difference test

# - in 0.5-16, SB.classic = TRUE is the default again (for now)
# - in 0.5-18, SB.classic is replaced by 'method', with the following
#   options:
#     method = "default" (we choose a default method, based on the estimator)
#     method = "standard" (option to explicitly avoid robust adjustment)
#     method = "Satorra.2000"
#     method = "Satorra.Bentler.2001"
#     method = "Satorra.Bentler.2010"
#     method = "mean.var.adjusted.PLRT"
#
# - 0.6-13: RMSEA.D (also known as 'RDR') is added to the table (also if scaled,
#           since 0.6-20)
# - 0.6-13: fix multiple-group UG^2 bug in Satorra.2000 (reported by
#           Gronneberg, Foldnes and Moss)
#
# - 0.6-18:
#     New option method = "standard" (to explicitly avoid robust adjustment)
#     New test= argument to select scaled stat when method="satorra.bentler.2001/2010"


lavTestLRT <- function(object, ..., method = "default", test = "default",
                       A.method = "delta", scaled.shifted = TRUE, # only when method="Satorra.2000"
                       type = "Chisq", model.names = NULL) {
  type <- tolower(type[1])
  test <- tolower(test[1])
  method <- tolower(gsub("[-_\\.]", "", method[1]))
  if (type %in% c("browne", "browne.residual.adf", "browne.residual.nt")) {
    if (type == "browne") {
      type <- "browne.residual.adf"
    }
    if (!method %in% c("default", "standard")) {
      lav_msg_stop(gettext(
        "method cannot be used if type is browne.residual.adf or
        browne.residual.nt"))
    }
    method <- "default"
  }

  # NOTE: if we add additional arguments, it is not the same generic
  # anova() function anymore, and match.call will be screwed up

  mcall <- match.call(expand.dots = TRUE)
  dots <- list(...)
  modp <- if (length(dots)) {
    sapply(dots, inherits, "lavaan")
  } else {
    logical(0L)
  }
  # check object
  object <- lav_object_check_version(object)
  # check models in dots
  dots[modp] <- lapply(dots[modp], lav_object_check_version)

  # some general properties (taken from the first model)
  estimator <- object@Options$estimator
  likelihood <- object@Options$likelihood
  ngroups <- object@Data@ngroups
  nobs <- object@SampleStats@nobs
  ntotal <- object@SampleStats@ntotal

  # TDJ: check for user-supplied h1 model
  user_h1_exists <- FALSE
  if (!is.null(object@external$h1.model)) {
    if (inherits(object@external$h1.model, "lavaan")) {
      user_h1_exists <- TRUE
    }
  }

  # shortcut for single argument (just plain LRT)
  if (!any(modp) && !user_h1_exists) {
    if (type == "cf") {
      lav_msg_warn(gettext("`type' argument is ignored for a single model"))
    }
    return(lav_test_lrt_single_model(object, method = method, test = test, type = type))
  }

  # list of models
  mods <- c(list(object), dots[modp])
  if (!is.null(model.names)) {
    names(mods) <- model.names
  } else {
    names(mods) <- sapply(
      as.list(mcall)[which(c(FALSE, TRUE, modp))],
      function(x) deparse(x)
    )
  }
  # TDJ: Add user-supplied h1 model, if it exists
  if (user_h1_exists) mods$user_h1 <- object@external$h1.model

  # put them in order (using degrees of freedom)
  ndf <- sapply(mods, function(x) x@test[[1]]$df)
  order.idx <- order(ndf)
  mods <- mods[order.idx]
  ndf <- ndf[order.idx]

  # here come the checks -- eventually, an option may skip this
  if (TRUE) {
    # 1. same set of observed variables?
    ov.names <- lapply(mods, function(x) {
      sort(lav_object_vnames(x))
    })
    OV <- ov.names[[1L]] # the observed variable names of the first model
    if (!all(sapply(ov.names, function(x) identical(x, OV)))) {
      lav_msg_warn(gettext(
        "some models are based on a different set of observed variables"))
    }
    ## wow FIXME: we may need to reorder the rows/columns first!!
    # COVS <- lapply(mods, function(x) slot(slot(x, "Sample"), "cov")[[1]])
    # if(!all(sapply(COVS, all.equal, COVS[[1]]))) {
    #    stop("lavaan ERROR: models must be fit to the same data")
    # }
    # 2. nested models? *different* npars?

    # TODO!

    # 3. all meanstructure?
    mean.structure <- sapply(mods, lavInspect, "meanstructure")
    if (sum(mean.structure) > 0L &&
      sum(mean.structure) < length(mean.structure)) {
      lav_msg_warn(gettext("not all models have a meanstructure"))
    }

    # 4. all converged?
    if (!all(sapply(mods, lavInspect, "converged"))) {
      lav_msg_warn(gettext("not all models converged"))
    }
  }

  mods.scaled <- unlist(lapply(mods, function(x) {
    any(c(
      "satorra.bentler", "yuan.bentler", "yuan.bentler.mplus",
      "mean.var.adjusted", "scaled.shifted"
    ) %in%
      unlist(sapply(slot(x, "test"), "[[", "test")))
  }))

  if (all(mods.scaled | ndf == 0) && any(mods.scaled)) {
    # Note: if df=0, test is not really robust, hence the above condition
    scaled <- TRUE
    # which test to choose by default?
    # i.e., not determined by method=
    scaledList <- sapply(mods[[ which(ndf > 0)[1] ]]@test, # first mod with df>0
                         #FIXME? If no mods have df > 0, this still yields error
                         function(x) !is.null(x$scaled.test.stat))
    scaled.idx <- which(scaledList)[[1]]
    default.TEST <- object@test[[scaled.idx]]$test
    if (test == "default") {
      TEST <- default.TEST
    } else if (!test %in% c("satorra.bentler", "yuan.bentler", "yuan.bentler.mplus",
                             "mean.var.adjusted", "scaled.shifted")) {
      lav_msg_stop(gettextf(
        "test = %s not found in object. See available tests in
        lavInspect(object, \"options\")$test.", dQuote(test)))
    } else TEST <- test

    ## is the test available from all models?
    check.scaled <- unlist(lapply(mods, function(x) {
      TEST %in% unlist(sapply(slot(x, "test"), "[[", "test"))
    }))

    if (any(!check.scaled)) {
      lav_msg_stop(gettextf(
        "test = %1$s not found in model(s): %2$s. Find available tests per model
        using lavInspect(fit, \"options\")$test.", dQuote(test),
        lav_msg_view(names(mods)[which(!check.scaled)], "none")))
    }

  } else if (!any(mods.scaled)) { # thanks to R.M. Bee to fix this
    scaled <- FALSE
    TEST <- "standard"
    method <- "standard"
  } else {
    lav_msg_stop(gettext(
      "some models (but not all) have scaled test statistics"))
  }
  if (type %in% c("browne.residual.adf", "browne.residual.nt")) {
    scaled <- FALSE
    method <- "standard"
  }
  if (method == "standard") {
    scaled <- FALSE
  }

  # select method
  if (method == "default") {
    if (estimator == "PML") {
      method <- "mean.var.adjusted.PLRT"
    } else if (scaled) {
      if (TEST %in% c(
        "satorra.bentler", "yuan.bentler",
        "yuan.bentler.mplus"
      )) {
        method <- "satorra.bentler.2001"
      } else {
        method <- "satorra.2000"
      }
    } else {
      # nothing to do
    }
  } else if (method == "meanvaradjustedplrt" ||
    method == "mean.var.adjusted.PLRT") {
    method <- "mean.var.adjusted.PLRT"
    stopifnot(estimator == "PML")
  } else if (method == "satorra2000") {
    method <- "satorra.2000"
  } else if (method == "satorrabentler2001") {
    method <- "satorra.bentler.2001"
  } else if (method == "satorrabentler2010") {
    method <- "satorra.bentler.2010"

    ## only option left:
  } else if (method != "standard") {
    lav_msg_stop(
      gettextf("unknown method for scaled difference test: %s.", method))
  }

  ## in case users specify method= or test= (but still type="chisq"),
  ## make sure the arguments are consistent for scaled tests
  if (method %in% c("satorra.bentler.2001","satorra.bentler.2010") && scaled &&
      (!TEST %in% c("satorra.bentler","yuan.bentler","yuan.bentler.mplus")) ) {
    lav_msg_stop(gettextf(
      "method = %s only available when models are fitted with test =
      \"satorra.bentler\", \"yuan.bentler\", or \"yuan.bentler.mplus\".",
      dQuote(method)))
  } else {
    ## method="satorra.2000" still available when TEST != scaled.shifted
    ## Or !scaled, so nothing to do.
  }

  # check method if scaled = FALSE
  if (type == "chisq" && !scaled &&
    method %in% c(
      "mean.var.adjusted.PLRT",
      "satorra.bentler.2001",
      "satorra.2000",
      "satorra.bentler.2010"
    )) {
    lav_msg_warn(gettextf(
      "method = %s but no robust test statistics were used; switching to the
      standard chi-squared difference test", dQuote(method)))
    method <- "standard"
  }


  # which models have used a MEANSTRUCTURE?
  mods.meanstructure <- sapply(mods, function(x) {
    unlist(slot(
      slot(x, "Model"),
      "meanstructure"
    ))
  })
  if (all(mods.meanstructure)) {
    meanstructure <- "ok"
  } else if (sum(mods.meanstructure) == 0) {
    meanstructure <- "ok"
  } else {
    lav_msg_stop(gettext("some models (but not all) have a meanstructure"))
  }

  # collect statistics for each model
  if (type == "chisq") {
    Df <- sapply(mods, function(x) slot(x, "test")[[1]]$df)
    STAT <- sapply(mods, function(x) slot(x, "test")[[1]]$stat)
  } else if (type == "browne.residual.nt") {
    TESTlist <- lapply(
      mods,
      function(x) lavTest(x, test = "browne.residual.nt")
    )
    Df <- sapply(TESTlist, function(x) x$df)
    STAT <- sapply(TESTlist, function(x) x$stat)
  } else if (type == "browne.residual.adf") {
    TESTlist <- lapply(
      mods,
      function(x) lavTest(x, test = "browne.residual.adf")
    )
    Df <- sapply(TESTlist, function(x) x$df)
    STAT <- sapply(TESTlist, function(x) x$stat)
  } else if (type == "cf") {
    tmp <- lapply(mods, lavTablesFitCf)
    STAT <- unlist(tmp)
    Df <- unlist(lapply(tmp, attr, "DF"))
  } else {
    lav_msg_stop(gettextf("test type unknown: %s", type))
  }

  # difference statistics
  STAT.delta <- STAT.delta.orig <- c(NA, diff(STAT))
  Df.delta <- Df.delta.orig <- c(NA, diff(Df))

  # check for negative values in STAT.delta
  # but with a tolerance (0.6-12)!
  if (any(STAT.delta[-1] < -1 * .Machine$double.eps^(1 / 3))) {
    lav_msg_warn(gettextf(
      "Some restricted models fit better than less restricted models; either
      these models are not nested, or the less restricted model failed to reach
      a global optimum.Smallest difference = %s.", min(STAT.delta[-1])))
  }

  # prepare for scaling versions
  if (method == "satorra.2000" && scaled.shifted) {
    a.delta <- b.delta <- rep(as.numeric(NA), length(STAT))
    c.delta <- NULL
  } else if (method %in% c("satorra.bentler.2001","satorra.bentler.2010",
                           "satorra.2000")) {
    c.delta <- rep(as.numeric(NA), length(STAT))
  }

  # correction for scaled test statistics
  if (type == "chisq" && scaled) {
    if (method == "satorra.bentler.2001") {
      # use formula from Satorra & Bentler 2001
      for (m in seq_len(length(mods) - 1L)) {
        out <- lav_test_diff_SatorraBentler2001(mods[[m]], mods[[m + 1]],
                                                # in case not @test[[2]]:
                                                test = TEST)
        STAT.delta[m + 1] <- out$T.delta
        Df.delta[m + 1] <- out$df.delta
        c.delta[m + 1] <- out$scaling.factor
      }
    } else if (method == "mean.var.adjusted.PLRT") {
      for (m in seq_len(length(mods) - 1L)) {
        out <- lav_pml_test_plrt(mods[[m]], mods[[m + 1]])
        STAT.delta[m + 1] <- out$FSMA.PLRT
        Df.delta[m + 1] <- out$adj.df
      }
    } else if (method == "satorra.bentler.2010") {
      for (m in seq_len(length(mods) - 1L)) {
        out <- lav_test_diff_SatorraBentler2010(mods[[m]], mods[[m + 1]],
          test = TEST, # in case not @test[[2]]
          H1 = FALSE
        ) # must be F

        STAT.delta[m + 1] <- out$T.delta
        Df.delta[m + 1] <- out$df.delta
        c.delta[m + 1] <- out$scaling.factor
      }
    } else if (method == "satorra.2000") {
      for (m in seq_len(length(mods) - 1L)) {
        if (TEST %in% c(
          "satorra.bentler", "yuan.bentler",
          "yuan.bentler.mplus"
        )) {
          Satterthwaite <- FALSE
        } else {
          Satterthwaite <- TRUE
         }
        out <- lav_test_diff_Satorra2000(mods[[m]], mods[[m + 1]],
          H1 = TRUE,
          Satterthwaite = Satterthwaite,
          scaled.shifted = scaled.shifted,
          A.method = A.method
        )
        STAT.delta[m + 1] <- out$T.delta
        Df.delta[m + 1] <- out$df.delta
        if (scaled.shifted) {
          a.delta[m + 1] <- out$a
          b.delta[m + 1] <- out$b
        } else {
          c.delta[m + 1] <- out$scaling.factor
        }
      }
    }
  }

  # check if scaled diff failed somehow
  if (scaled &&
     ( (method %in% c("satorra.bentler.2001", "satorra.bentler.2010") &&
          is.na(out$scaling.factor)) ||
         (method == "satorra.2000" && scaled.shifted && is.na(out$a)) ||
         (method == "satorra.2000" && !scaled.shifted &&
          is.na(out$scaling.factor)) )
     ) {
    scaled <- FALSE
  }


  # unname
  STAT.delta <- unname(STAT.delta)
  # zap small values (for near-zero values) (anova class does not use rounding)
  STAT.delta <- round(STAT.delta, 10)
  Df.delta <- unname(Df.delta)
  STAT.delta.orig <- unname(STAT.delta.orig)
  Df.delta.orig <- unname(Df.delta.orig)
  if (scaled && !is.null(c.delta)) {
    c.delta <- unname(c.delta)
  }

  # Pvalue
  Pvalue.delta <- pchisq(STAT.delta, Df.delta, lower.tail = FALSE)

  # new in 0.6-13: RMSEA (RMSEA.D or RDR)
  if (object@Options$missing == "listwise") {
    if (scaled && !is.null(c.delta)) {
      c.hat <- c.delta[-1]
    } else {
      c.hat <- rep(1, length(STAT.delta.orig) - 1L)
    }
    RMSEA.delta <- c(NA, lav_fit_rmsea(
      X2 = STAT.delta.orig[-1],
      df = Df.delta.orig[-1],
      N = ntotal,
      G = ngroups,
      c.hat = c.hat
    ))
  }

  # AIC/BIC
  aic <- bic <- rep(NA, length(mods))
  if (estimator == "ML") {
    aic <- sapply(mods, FUN = AIC)
    bic <- sapply(mods, FUN = BIC)
  } else if (estimator == "PML") {
    OUT <- lapply(mods, lav_pml_object_aic_bic)
    aic <- sapply(OUT, "[[", "PL_AIC")
    bic <- sapply(OUT, "[[", "PL_BIC")
  }

  if (estimator == "PML") {
    val <- data.frame(
      Df = Df,
      PL_AIC = aic,
      PL_BIC = bic,
      Chisq = STAT,
      "Chisq diff" = STAT.delta,
      "Df diff" = Df.delta,
      "Pr(>Chisq)" = Pvalue.delta,
      row.names = names(mods),
      check.names = FALSE
    )
  } else if (object@Options$missing == "listwise") {
    val <- data.frame(
      Df = Df,
      AIC = aic,
      BIC = bic,
      Chisq = STAT,
      "Chisq diff" = STAT.delta,
      "RMSEA" = RMSEA.delta,
      "Df diff" = Df.delta,
      "Pr(>Chisq)" = Pvalue.delta,
      row.names = names(mods),
      check.names = FALSE
    )
  } else {
    val <- data.frame(
      Df = Df,
      AIC = aic,
      BIC = bic,
      Chisq = STAT,
      "Chisq diff" = STAT.delta,
      #"RMSEA" = RMSEA.delta, # if missing, not yet...
      "Df diff" = Df.delta,
      "Pr(>Chisq)" = Pvalue.delta,
      row.names = names(mods),
      check.names = FALSE
    )
  }

  # catch Df.delta == 0 cases (reported by Florian Zsok in Zurich)
  # but only if there are no inequality constraints! (0.6-1)
  idx <- which(val[, "Df diff"] == 0)
  if (length(idx) > 0L) {
    # remove models with inequality constraints
    ineq.idx <- which(sapply(lapply(mods, function(x)
      slot(slot(x, "Model"), "x.cin.idx")), length) > 0L)
    rm.idx <- which(idx %in% ineq.idx)
    if (length(rm.idx) > 0L) {
      idx <- idx[-rm.idx]
    }
  }
  if (length(idx) > 0L) {
    val[idx, "Pr(>Chisq)"] <- as.numeric(NA)
    lav_msg_warn(gettext("some models have the same degrees of freedom"))
  }

  if (type == "chisq") {
    if (scaled) {
      txt <- paste("The ", dQuote("Chisq"), " column contains standard ",
        "test statistics, not the robust test that should be ",
        "reported per model. A robust difference test is a ",
        "function of two standard (not robust) statistics.",
        sep = ""
      )
      attr(val, "heading") <-
        paste("\nScaled Chi-Squared Difference Test (method = ",
          dQuote(method), ")\n\n",
          lav_msg(paste("lavaan NOTE:", txt), showheader = TRUE),
          "\n",
          sep = ""
        )
      if (method == "satorra.2000" && scaled.shifted) {
        attr(val, "scale") <- a.delta
        attr(val, "shift") <- b.delta
      } else if (method %in% c("satorra.bentler.2001","satorra.bentler.2010",
                               "satorra.2000")) {
        attr(val, "scale") <- c.delta
      }
    } else {
      attr(val, "heading") <- "\nChi-Squared Difference Test\n"
    }
  } else if (type == "browne.residual.adf") {
    attr(val, "heading") <- "\nChi-Squared Difference Test based on Browne's residual (ADF) Test\n"
  } else if (type == "browne.residual.nt") {
    attr(val, "heading") <- "\nChi-Squared Difference Test based on Browne's residual (NT) Test\n"
  } else if (type == "cf") {
    colnames(val)[c(3, 4)] <- c("Cf", "Cf diff")
    attr(val, "heading") <- "\nCf Difference Test\n"
  }
  class(val) <- c("anova", class(val))

  return(val)
}


# anova table for a single model
lav_test_lrt_single_model <- function(object, method = "default",
                                      test = "default", type = "Chisq") {
  estimator <- object@Options$estimator

  aic <- bic <- c(NA, NA)
  if (estimator == "ML") {
    aic <- c(NA, AIC(object))
    bic <- c(NA, BIC(object))
  }

  ## determine which @test element
  tn <- names(object@test)
  if (is.null(tn)) {
    tn <- "standard" # for lavaan <0.6 objects
  }
  if (length(tn) == 1L) {
    TEST <- 1L # only choice

    ## More than 1.  Cycle through possible user specifications:
  } else if (method[1] == "standard") {
    TEST <- 1L
  } else if (grepl(pattern = "browne", x = type) && type %in% tn) {
    TEST <- type
  } else if (test %in% tn) {
    TEST <- test
  } else {
    ## Nothing explicitly (or validly) requested.
    ## But there is > 1 test, so take the second element (old default)
    TEST <- 2L
  }

  ## anova table
  val <- data.frame(
    Df = c(0, object@test[[TEST]]$df),
    AIC = aic,
    BIC = bic,
    Chisq = c(0, object@test[[TEST]]$stat),
    "Chisq diff" = c(NA, object@test[[TEST]]$stat),
    "Df diff" = c(NA, object@test[[TEST]]$df),
    "Pr(>Chisq)" = c(NA, object@test[[TEST]]$pvalue),
    row.names = c("Saturated", "Model"),
    check.names = FALSE
  )
  ## scale/shift attributes
  if (!is.null(object@test[[TEST]]$scaling.factor)) {
    attr(val, "scale") <- c(NA, object@test[[TEST]]$scaling.factor)
  }
  if (!is.null(object@test[[TEST]]$shift.parameter)) {
    attr(val, "shift") <- c(NA, object@test[[TEST]]$shift.parameter)
  }

  ## heading
  if (grepl(pattern = "browne", x = TEST)) {
    attr(val, "heading") <- object@test[[TEST]]$label

  } else if (TEST == 1L) {
    attr(val, "heading") <- "Chi-Squared Test Statistic (unscaled)\n"

  } else {
    LABEL <- object@test[[TEST]]$label
    attr(val, "heading") <- paste0("Chi-Squared Test Statistic (scaled",
                                   ifelse(TEST == "scaled.shifted",
                                          yes = " and shifted)", no = ")"),
                                   ifelse(is.null(LABEL),
                                          yes = "\n", no = paste("\n ", LABEL)),
                                   "\n")
  }

  class(val) <- c("anova", class(val))

  val
}

# simulate data starting from a user-specified model
#
# initial version: YR 24 jan 2011
# revision for 0.4-11: YR 21 okt 2011
#
#
#
lav_data_simulate_old <- function( # user-specified model
                         model = NULL,
                         model.type = "sem",
                         # model modifiers
                         meanstructure = FALSE,
                         int.ov.free = TRUE,
                         int.lv.free = FALSE,
                         marker.int.zero = FALSE,
                         conditional.x = FALSE,
                         composites = TRUE,
                         fixed.x = FALSE,
                         orthogonal = FALSE,
                         std.lv = TRUE,
                         auto.fix.first = FALSE,
                         auto.fix.single = FALSE,
                         auto.var = TRUE,
                         auto.cov.lv.x = TRUE,
                         auto.cov.y = TRUE,
                         ...,
                         # data properties
                         sample.nobs = 500L,
                         ov.var = NULL,
                         group.label = paste("G", 1:ngroups, sep = ""),
                         skewness = NULL,
                         kurtosis = NULL,
                         # control
                         seed = NULL,
                         empirical = FALSE,
                         return.type = "data.frame",
                         return.fit = FALSE,
                         debug = FALSE,
                         standardized = FALSE) {
  if (!missing(debug)) {
    current.debug <- lav_debug()
    if (lav_debug(debug))
      on.exit(lav_debug(current.debug), TRUE)
  }
  if (!is.null(seed)) set.seed(seed)
  # if(!exists(".Random.seed", envir = .GlobalEnv))
  #    runif(1)               # initialize the RNG if necessary
  # RNGstate <- .Random.seed

  # lav_model_partable
  if (is.list(model)) {
    # two possibilities: either model is already lavaanified
    # or it is something else...
    if (!is.null(model$lhs) && !is.null(model$op) &&
      !is.null(model$rhs) && !is.null(model$free)) {
      lav <- model

      # until 0.6-5, we only used the 'ustart' column
      # but what if 'lav' is a fitted lavaan object -> use 'est'
      if (!is.null(lav$est)) {
        lav$ustart <- lav$est
        lav$se <- NULL
        lav$est <- NULL
        lav$start <- NULL
      }
    } else if (is.character(model[[1]])) {
      lav_msg_stop(gettext("model is a list, but not a parameterTable?"))
    }
  } else {
    lav <- lav_model_partable(
      model = model,
      meanstructure = meanstructure,
      int.ov.free = int.ov.free,
      int.lv.free = int.lv.free,
      marker.int.zero = marker.int.zero,
      composites = composites,
      conditional.x = conditional.x,
      fixed.x = fixed.x,
      orthogonal = orthogonal,
      std.lv = std.lv,
      auto.fix.first = auto.fix.first,
      auto.fix.single = auto.fix.single,
      auto.var = auto.var,
      auto.cov.lv.x = auto.cov.lv.x,
      auto.cov.y = auto.cov.y,
      ngroups = length(sample.nobs)
    )
  }

  group.values <- lav_partable_group_values(lav)
  if (lav_debug()) {
    cat("initial lav\n")
    print(as.data.frame(lav))
  }

  # fill in any remaining NA values (needed for unstandardize)
  # 1 for variances and (unstandardized) factor loadings, 0 otherwise
  idx <- which(lav$op == "=~" & is.na(lav$ustart))
  if (length(idx) > 0L) {
    if (standardized) {
      lav$ustart[idx] <- 0.7
    } else {
      lav$ustart[idx] <- 1.0
    }
  }

  idx <- which(lav$op == "~~" & is.na(lav$ustart) & lav$lhs == lav$rhs)
  if (length(idx) > 0L) lav$ustart[idx] <- 1.0

  idx <- which(lav$op == "~" & is.na(lav$ustart))
  if (length(idx) > 0L) {
    lav_msg_warn(gettext(
      "some regression coefficients are unspecified and will be set to zero"))
  }

  idx <- which(is.na(lav$ustart))
  if (length(idx) > 0L) lav$ustart[idx] <- 0.0

  if (lav_debug()) {
    cat("lav + default values\n")
    print(as.data.frame(lav))
  }

  # set residual variances to enforce a standardized solution
  # but only if no *residual* variances have been specified in the syntax

  if (standardized) {
    # check if factor loadings are smaller than 1.0
    lambda.idx <- which(lav$op == "=~")
    if (any(lav$ustart[lambda.idx] >= 1.0)) {
      lav_msg_warn(gettext("standardized=TRUE but factor loadings are >= 1.0"))
    }

    # check if regression coefficients are smaller than 1.0
    reg.idx <- which(lav$op == "~")
    if (any(lav$ustart[reg.idx] >= 1.0)) {
      lav_msg_warn(gettext(
        "standardized=TRUE but regression coefficients are >= 1.0"))
    }

    # for ordered observed variables, we will get '0.0', but that is ok
    # so there is no need to make a distinction between numeric/ordered
    # here??
    ngroups <- lav_partable_ngroups(lav)
    ov.names <- lav_partable_vnames(lav, "ov")
    ov.nox <- lav_partable_vnames(lav, "ov.nox")
    lv.names <- lav_partable_vnames(lav, "lv")
    lv.y <- lav_partable_vnames(lav, "lv.y")
    lv.nox <- lav_partable_vnames(lav, "lv.nox")
    ov.var.idx <- which(lav$op == "~~" & lav$lhs %in% ov.nox &
      lav$rhs == lav$lhs)
    lv.var.idx <- which(lav$op == "~~" & lav$lhs %in% lv.nox &
      lav$rhs == lav$lhs)
    if (any(lav$user[c(ov.var.idx, lv.var.idx)] > 0L)) {
      lav_msg_warn(gettext(
        "if residual variances are specified, please use standardized=FALSE"))
    }

    # new in 0.6-20: - use lav_lisrel_residual_variances
    #                - use lav_lisrel_composites_variances
    dotdotdot <- list(...)
    dotdotdot$sample.nobs <- sample.nobs
    dotdotdot$fixed.x <- FALSE # for now
    dotdotdot$representation <- "LISREL"
    dotdotdot$composites <- composites
    dotdotdot$correlation <- TRUE # this is the trick
    tmp.fit <- do.call("lavaan", args = c(list(model = lav), dotdotdot))
    # set/get parameters to invoke lav_lisrel_residual_variances
    tmp.lav <- tmp.fit@ParTable
    tmp.x <- lav_model_get_parameters(tmp.fit@Model)
    tmp.model <- lav_model_set_parameters(tmp.fit@Model, x = tmp.x)
    tmp.lav$ustart <- lav_model_get_parameters(tmp.model, type = "user")

    # copy residual values to lav (without assuming parameter tables look the
    # same)
    res.idx <- c(ov.var.idx, lv.var.idx)
    for (i in seq_len(length(res.idx))) {
      # lookup this parameter in tmp.lav
      idx.in.lav <- res.idx[i]
      this.lhs <- lav$lhs[idx.in.lav]
      idx.in.tmp <- which(tmp.lav$op == "~~" & tmp.lav$lhs == this.lhs &
                          tmp.lav$rhs == tmp.lav$lhs)
      if (length(idx.in.tmp) == 0L) {
        # hm, not found? Give a warning?
      } else {
        vals <- tmp.lav$ustart[idx.in.tmp]
        # check if we have unfortunate values
        bad.idx <- which(!is.finite(vals) | vals < 0)
        vals[bad.idx] <- 1.0 # not pretty, but safe
        lav$ustart[idx.in.lav] <- vals
      }
    }

    # this is what we did <0.6-20
    # fit <- lavaan(model = lav, sample.nobs = sample.nobs, ...)
    # Sigma.hat <- lav_model_sigma(lavmodel = fit@Model)
    # ETA <- lav_model_veta(lavmodel = fit@Model)

    # if (lav_debug()) {
    #   cat("Sigma.hat:\n")
    #   print(Sigma.hat)
    #   cat("Eta:\n")
    #   print(ETA)
    # }

    # # stage 1: standardize LV
    # if (length(lv.nox) > 0L) {
    #   for (g in 1:ngroups) {
    #     var.group <- which(lav$op == "~~" & lav$lhs %in% lv.nox &
    #       lav$rhs == lav$lhs &
    #       lav$group == group.values[g])
    #     eta.idx <- match(lv.nox, lv.names)
    #     lav$ustart[var.group] <- 1 - diag(ETA[[g]])[eta.idx]
    #   }
    # }
    # # refit
    # fit <- lavaan(model = lav, sample.nobs = sample.nobs, ...)
    # Sigma.hat <- lav_model_sigma(lavmodel = fit@Model)

    # if (lav_debug()) {
    #   cat("after stage 1:\n")
    #   cat("Sigma.hat:\n")
    #   print(Sigma.hat)
    # }

    # # stage 2: standardize OV
    # for (g in 1:ngroups) {
    #   var.group <- which(lav$op == "~~" & lav$lhs %in% ov.nox &
    #     lav$rhs == lav$lhs &
    #     lav$group == group.values[g])
    #   ov.idx <- match(ov.nox, ov.names)
    #   lav$ustart[var.group] <- 1 - diag(Sigma.hat[[g]])[ov.idx]
    # }

    # if (lav_debug()) {
    #   cat("after standardisation lav\n")
    #   print(as.data.frame(lav))
    # }
  }


  # unstandardize
  if (!is.null(ov.var)) {
    # FIXME: if ov.var is named, check the order of the elements

    # 1. unstandardize observed variables
    lav$ustart <- lav_unstandardize_ov(partable = lav, ov.var = ov.var)

    # 2. unstandardized latent variables

    if (lav_debug()) {
      cat("after unstandardisation lav\n")
      print(as.data.frame(lav))
    }
  }

  # fit the model without data
  fit <- lavaan(model = lav, sample.nobs = sample.nobs, ...)

  # the model-implied moments for the population
  Sigma.hat <- lav_model_sigma(lavmodel = fit@Model)
  Mu.hat <- lav_model_mu(lavmodel = fit@Model)
  if (fit@Model@categorical) {
    TH <- lav_model_th(lavmodel = fit@Model)
  }

  if (lav_debug()) {
    cat("\nModel-implied moments (before Vale-Maurelli):\n")
    print(Sigma.hat)
    print(Mu.hat)
    if (exists("TH")) print(TH)
  }

  # ngroups
  ngroups <- length(sample.nobs)

  # prepare
  X <- vector("list", length = ngroups)
  out <- vector("list", length = ngroups)

  for (g in 1:ngroups) {
    COV <- Sigma.hat[[g]]

    # if empirical = TRUE, rescale by N/(N-1), so that estimator=ML
    # returns exact results
    if (empirical) {
      COV <- COV * sample.nobs[g] / (sample.nobs[g] - 1)
    }

    # Using sign-invariant method for cross-machine reproducibility
    if (is.null(skewness) && is.null(kurtosis)) {
      X[[g]] <- lav_mvrnorm(
        n = sample.nobs[g],
        mu = Mu.hat[[g]],
        Sigma = COV,
        empirical = empirical
      )
    } else {
      # first generate Z
      Z <- lav_data_valemaurelli1983(
        n = sample.nobs[g],
        COR = cov2cor(COV),
        skewness = skewness, # FIXME: per group?
        kurtosis = kurtosis
      )
      # rescale
      # Note: 'scale()' will first center, and then scale
      # but we need to first scale, and then center...
      # this was reported by Jordan Brace (9 may 2014)
      # X[[g]] <- scale(Z, center = -Mu.hat[[g]],
      #                   scale  = 1/sqrt(diag(COV)))

      # first, we scale
      TMP <- scale(Z,
        center = FALSE,
        scale = 1 / sqrt(diag(COV))
      )[, , drop = FALSE]

      # then, we center
      X[[g]] <- sweep(TMP, MARGIN = 2, STATS = Mu.hat[[g]], FUN = "+")
    }

    # any categorical variables?
    ov.ord <- lav_partable_vnames(lav, type = "ov.ord", group = group.values[g])
    if (length(ov.ord) > 0L) {
      ov.names <- lav_partable_vnames(lav, type = "ov", group = group.values[g])
      # use thresholds to cut
      for (o in ov.ord) {
        o.idx <- which(o == ov.names)
        th.idx <- which(lav$op == "|" & lav$lhs == o &
          lav$group == group.values[g])
        th.val <- c(-Inf, sort(lav$ustart[th.idx]), +Inf)
        X[[g]][, o.idx] <- as.integer(cut(X[[g]][, o.idx], th.val))
      }
    }

    if (return.type == "data.frame") X[[g]] <- as.data.frame(X[[g]])
  }

  if (return.type == "matrix") {
    if (ngroups == 1L) {
      return(X[[1L]])
    } else {
      return(X)
    }
  } else if (return.type == "data.frame") {
    Data <- X[[1L]]

    # if multiple groups, add group column
    if (ngroups > 1L) {
      for (g in 2:ngroups) {
        Data <- rbind(Data, X[[g]])
      }
      Data$group <- rep(1:ngroups, times = sample.nobs)
    }
    var.names <- lav_partable_vnames(fit@ParTable, type = "ov", group = 1L)
    if (ngroups > 1L) var.names <- c(var.names, "group")
    names(Data) <- var.names
    if (return.fit) {
      attr(Data, "fit") <- fit
    }
    return(Data)
  } else if (return.type == "cov") {
    if (ngroups == 1L) {
      return(cov(X[[1L]]))
    } else {
      cov.list <- lapply(X, cov)
      return(cov.list)
    }
  }
}
lavSimulateData <- lav_data_simulate_old  # synonym #nolint

lav_skewness <- function(x., N1 = TRUE) {
  x <- x.
  x <- x[!is.na(x)]
  N <- length(x)
  mean.x <- mean(x)
  xc <- x - mean.x
  var.x <- var(x)
  if (!N1) var.x <- var.x * (N - 1) / N
  sd.x <- sqrt(var.x)
  sk <- sum(xc * xc * xc) / (sd.x * sd.x * sd.x)
  skewness <- N * sk / ((N - 1) * (N - 2))
  skewness
}

lav_kurtosis <- function(x., N1 = TRUE) {
  x <- x.
  x <- x[!is.na(x)]
  N <- length(x)
  mean.x <- mean(x)
  xc <- x - mean.x
  var.x <- var(x)
  if (!N1) var.x <- var.x * (N - 1) / N
  k <- sum(xc * xc * xc * xc) / (var.x * var.x)
  kurtosis <- N * (N + 1) * k / ((N - 1) * (N - 2) * (N - 3)) - 3 * (N - 1) * (N - 1) / ((N - 2) * (N - 3))
  kurtosis
}



lav_data_valemaurelli1983 <- function(n = 100L, COR, skewness, kurtosis) {
  fleishman1978_abcd <- function(skewness, kurtosis) {
    system.function <- function(x, skewness, kurtosis) {
      b. <- x[1L]
      c. <- x[2L]
      d. <- x[3L]
      eq1 <- b. * b. + 6 * b. * d. + 2 * c. * c. + 15 * d. * d. - 1
      eq2 <- 2 * c. * (b. * b. + 24 * b. * d. + 105 * d. * d. + 2) - skewness
      eq3 <- 24 * (b. * d. + c. * c. * (1 + b. * b. + 28 * b. * d.) +
        d. * d. * (12 + 48 * b. * d. + 141 * c. * c. + 225 * d. * d.)) - kurtosis
      eq <- c(eq1, eq2, eq3)
      sum(eq * eq) ## SS
    }

    out <- nlminb(
      start = c(1, 0, 0), objective = system.function,
      scale = 10,
      control = list(trace = 0),
      skewness = skewness, kurtosis = kurtosis
    )
    if (out$convergence != 0 || out$objective > 1e-5) {
      lav_msg_warn(gettext("lav_data_valemaurelli1983 method did not convergence,
                   or it did not find the roots"))
    }
    b. <- out$par[1L]
    c. <- out$par[2L]
    d. <- out$par[3L]
    a. <- -c.
    c(a., b., c., d.)
  }

  getICOV <- function(b1, c1, d1, b2, c2, d2, R) {
    objectiveFunction <- function(x, b1, c1, d1, b2, c2, d2, R) {
      rho <- x[1L]
      eq <- rho * (b1 * b2 + 3 * b1 * d2 + 3 * d1 * b2 + 9 * d1 * d2) +
        rho * rho * (2 * c1 * c2) + rho * rho * rho * (6 * d1 * d2) - R
      eq * eq
    }

    # gradientFunction <- function(x, bcd1, bcd2, R) {
    #
    # }

    out <- nlminb(
      start = R, objective = objectiveFunction,
      scale = 10, control = list(trace = 0),
      b1 = b1, c1 = c1, d1 = d1, b2 = b2, c2 = c2, d2 = d2, R = R
    )
    if (out$convergence != 0 || out$objective > 1e-5)
      lav_msg_warn(gettext("no convergence"))
    rho <- out$par[1L]
    rho
  }

  # number of variables
  nvar <- ncol(COR)
  # check skewness
  if (is.null(skewness)) {
    SK <- rep(0, nvar)
  } else if (length(skewness) == nvar) {
    SK <- skewness
  } else if (length(skewness) == 1L) {
    SK <- rep(skewness, nvar)
  } else {
    lav_msg_stop(gettext("skewness has wrong length"))
  }

  if (is.null(kurtosis)) {
    KU <- rep(0, nvar)
  } else if (length(kurtosis) == nvar) {
    KU <- kurtosis
  } else if (length(kurtosis) == 1L) {
    KU <- rep(kurtosis, nvar)
  } else {
    lav_msg_stop(gettext("kurtosis has wrong length"))
  }

  # create Fleishman table
  FTable <- matrix(0, nvar, 4L)
  for (i in 1:nvar) {
    FTable[i, ] <- fleishman1978_abcd(skewness = SK[i], kurtosis = KU[i])
  }

  # compute intermediate correlations between all pairs
  ICOR <- diag(nvar)
  for (j in 1:(nvar - 1L)) {
    for (i in (j + 1):nvar) {
      if (COR[i, j] == 0) next
      ICOR[i, j] <- ICOR[j, i] <-
        getICOV(FTable[i, 2], FTable[i, 3], FTable[i, 4],
          FTable[j, 2], FTable[j, 3], FTable[j, 4],
          R = COR[i, j]
        )
    }
  }

  if (lav_debug()) {
    cat("\nOriginal correlations (for Vale-Maurelli):\n")
    print(COR)
    cat("\nIntermediate correlations (for Vale-Maurelli):\n")
    print(ICOR)
    cat("\nEigen values ICOR:\n")
    print(eigen(ICOR)$values)
  }

  # generate Z (using sign-invariant method for cross-machine reproducibility)
  X <- Z <- lav_mvrnorm(n = n, mu = rep(0, nvar), Sigma = ICOR)

  # transform Z using Fleishman constants
  for (i in 1:nvar) {
    X[, i] <- FTable[i, 1L] + FTable[i, 2L] * Z[, i] + FTable[i, 3L] * Z[, i] * Z[, i] +
      FTable[i, 4L] * Z[, i] * Z[, i] * Z[, i]
  }

  X
}

# step 1 in SAM: fitting the measurement blocks

lav_sam_step1 <- function(cmd = "sem", mm.list = NULL, mm.args = list(),
                          FIT = FIT, sam.method = "local") {
  lavoptions <- FIT@Options
  lavpta <- FIT@pta
  PT <- FIT@ParTable
  nblocks <- lavpta$nblocks
  ngroups <- lavpta$ngroups

  if (lav_verbose()) {
    cat("Fitting the measurement part:\n")
  }

  # local only -> handle missing data
  # if (sam.method %in% c("local", "fsr")) {
  #   # if missing = "listwise", make data complete, to avoid different
  #   # datasets per measurement block
  #   if (lavoptions$missing == "listwise") {
  #     # FIXME: make this work for multiple groups!!
  #     OV <- unique(unlist(FIT@pta$vnames$ov))
  #     # add group/cluster/sample.weights variables (if any)
  #     OV <- c(
  #       OV, FIT@Data@group, FIT@Data@cluster,
  #       FIT@Data@sampling.weights
  #     )
  #     data <- na.omit(data[, OV])
  #   }
  # }

  # total number of free parameters
  if (FIT@Model@ceq.simple.only) {
    npar <- FIT@Model@nx.unco
    PT.free <- PT$free
    PT.free[PT.free > 0] <- seq_len(npar)
  } else {
    npar <- FIT@Model@nx.free
    PT.free <- PT$free
  }
  if (npar < 1L) {
    lav_msg_stop(gettext("model does not contain any free parameters"))
  }

  # do we have at least 1 'regular' (measured) latent variable?
  LV.names <- unique(unlist(FIT@pta$vnames$lv.regular))

  eqs.x <- unlist(FIT@pta$vnames$eqs.x)
  eqs.y <- unlist(FIT@pta$vnames$eqs.y)

  #if (length(eqs.x) == 0L && length(eqs.y) == 0L) {
  #  lav_msg_warn(gettext("the model does seem to contain a structural part
  #                        (i.e., regressions); consider using sem() instead"))
  #} else
  if (length(LV.names) == 0L) {
    lav_msg_warn(gettext("structural model does not contain any (measured)
                          latent variables; consider using sem() instead"))
  }

  # check for higher-order factors
  # 0.6-20: now we do!
  LV.IND.names <- unique(unlist(FIT@pta$vnames$lv.ind))
  lv.higherorder.flag <- FALSE
  if (length(LV.IND.names) > 0L) {
    lv.higherorder.flag <- TRUE
    LV.names <- LV.names[!LV.names %in% LV.IND.names]
  }

  # how many measurement models?
  if (!is.null(mm.list)) {
    nMMblocks <- length(mm.list)
    # check each measurement block
    for (b in seq_len(nMMblocks)) {
      # check if we can find all lv names in LV.names
      if (!all(unlist(mm.list[[b]]) %in% LV.names)) {
        tmp <- unlist(mm.list[[b]])
        lav_msg_stop(gettext("mm.list contains unknown latent variable(s):"),
          lav_msg_view(tmp[!tmp %in% LV.names], "none"))
      }
      # make list per block
      if (!is.list(mm.list[[b]])) {
        mm.list[[b]] <- rep(list(mm.list[[b]]), nblocks)
      } else {
        if (length(mm.list[[b]]) != nblocks) {
          lav_msg_stop(gettextf(
            "mm.list block %1$s has length %2$s but nblocks = %3$s",
            b, length(mm.list[[b]]), nblocks))
        }
      }
    }
  } else {
    mm.list.per.block <- lav_sam_get_mmlist(FIT)
    # we get a list PER BLOCK
    # for now, we only keep the first block
    mm.list <- mm.list.per.block[[1]]
    nMMblocks <- length(mm.list)
  }

  # adjust options for measurement models
  lavoptions.mm <- lavoptions
  lavoptions.mm$optim.bounds <- NULL
  if (lavoptions$se %in% c("none", "bootstrap")) {
    lavoptions.mm$se <- "none"
  } else {
    # categorical?
    if (FIT@Model@categorical) {
      lavoptions.mm$se <- "robust.sem"
    } else if (lavoptions$estimator.orig == "MLM") {
      lavoptions.mm$se <- "robust.sem"
    } else if (lavoptions$estimator.orig == "MLR") {
      lavoptions.mm$se <- "robust.huber.white"
    } else if (lavoptions$estimator.orig == "PML") {
      lavoptions.mm$se <- "robust.huber.white"
    } else {
      lavoptions.mm$se <- "standard" # may be overriden later
    }
  }
  # if(sam.method == "global") {
  #    lavoptions.mm$test <- "none"
  # }
  # we need the tests to create summary info about MM
  lavoptions.mm$check.post <- FALSE # neg lv variances may be overriden
  lavoptions.mm$check.gradient <- FALSE # too sensitive in large model (global)
  lavoptions.mm$baseline <- FALSE
  lavoptions.mm$bounds <- "wide.zerovar"

  # ALWAYS conditional.x = FALSE!
  # even if global model uses conditional.x = TRUE
  # this should not affect the measurement models (if the covariates act on
  # the structural part only)
  lavoptions.mm$conditional.x = FALSE

  # override with user-specified mm.args
  lavoptions.mm <- modifyList(lavoptions.mm, mm.args)

  # create MM slotOptions
  slotOptions.mm <- lav_options_set(lavoptions.mm)

  # we assume the same number/names of lv's per group!!!
  MM.FIT <- vector("list", nMMblocks) # fitted object

  # for joint model later
  if (!lavoptions$se %in% c("none", "bootstrap")) {
    Sigma.11 <- matrix(0, npar, npar)
    colnames(Sigma.11) <- rownames(Sigma.11) <-
      lav_partable_labels(FIT@ParTable, type = "free")
  }
  step1.free.idx <- integer(0L)
  block.mm.idx  <- vector("list", length = nMMblocks)
  block.ptm.idx <- vector("list", length = nMMblocks)

  # NOTE: we should explicitly add zero-constrained LV covariances
  # to PT, and keep them zero in PTM
  if (cmd == "lavaan") {
    add.lv.cov <- FALSE
  } else {
    add.lv.cov <- TRUE
  }

  # fit mm model for each measurement block
  for (mm in seq_len(nMMblocks)) {
    if (lav_verbose()) {
      cat(
        "  block ", mm, "[",
        paste(mm.list[[mm]], collapse = " "), "]\n"
      )
    }

    # create parameter table for this measurement block only
    PTM <- lav_partable_subset_measurement_model(
      PT = PT,
      add.lv.cov = add.lv.cov,
      add.idx = TRUE,
      lv.names = mm.list[[mm]],
    )
    mm.idx <- attr(PTM, "idx")
    attr(PTM, "idx") <- NULL
    PTM$est <- NULL
    PTM$se <- NULL
    block.mm.idx[[mm]] <- mm.idx

    # check for categorical in PTM in this mm-block
    if (!any(PTM$op == "|")) {
      slotOptions.mm$categorical <- FALSE
      slotOptions.mm$.categorical <- FALSE
    }

    # update slotData for this measurement block
    ov.names.block <- lapply(1:ngroups, function(g) {
      unique(unlist(lav_partable_vnames(PTM, type = "ov", group = g)))
    })
    slotData.block <- lav_data_update_subset(FIT@Data,
      ov.names = ov.names.block
    )
    # get rid of ov.names.x
    if (!slotOptions.mm$conditional.x) {
      slotData.block@ov.names.x <-
        lapply(seq_len(nblocks), function(x) character(0L))
      slotData.block@eXo <-
        lapply(seq_len(nblocks), function(x) NULL)
    }

    # if data.type == "moment", (re)create sample.cov and sample.nobs
    if (FIT@Data@data.type == "moment") {
      if (ngroups == 1L) {
        mm.sample.cov <- lavInspect(FIT, "h1")$cov
        mm.sample.mean <- NULL
        if (FIT@Model@meanstructure) {
          mm.sample.mean <- lavInspect(FIT, "h1")$mean
        }
        mm.sample.nobs <- FIT@SampleStats@nobs[[1L]]
      } else {
        cov.list <- lapply(lavTech(FIT, "h1", add.labels = TRUE),
                           "[[", "cov")
        mm.sample.cov <- lapply(seq_len(ngroups),
          function(x) cov.list[[x]][ov.names.block[[x]], ov.names.block[[x]]])
        mm.sample.mean <- NULL
        if (FIT@Model@meanstructure) {
          mean.list <- lapply(lavTech(FIT, "h1", add.labels = TRUE),
                           "[[", "mean")
          mm.sample.mean <- lapply(seq_len(ngroups),
            function(x) mean.list[[x]][ov.names.block[[x]]])
        }
        mm.sample.nobs <- FIT@SampleStats@nobs
      }
    }


    # handle single block 1-factor CFA with (only) two indicators
    if (length(unlist(ov.names.block)) == 2L && ngroups == 1L) {
      lambda.idx <- which(PTM$op == "=~")
	  # check if both factor loadings are fixed
	  # (note: this assumes std.lv = FALSE)
	  if(any(PTM$free[lambda.idx] != 0)) {
        PTM$free[  lambda.idx] <- 0L
        PTM$ustart[lambda.idx] <- 1
        PTM$start[ lambda.idx] <- 1
        free.idx <- which(as.logical(PTM$free))
		# adjust free counter
        if (length(free.idx) > 0L) {
          PTM$free[free.idx] <- seq_len(length(free.idx))
        }
		# warn about it (needed?)
        lav_msg_warn(gettextf(
          "measurement block [%1$s] (%2$s) contains only two indicators;
          -> fixing both factor loadings to unity",
          mm, lav_msg_view(mm.list[[mm]], "none")))
      }
    }

    # fit this measurement model only
    # (question: can we re-use even more slots?)
    if (FIT@Data@data.type == "full") {
      fit.mm.block <- lavaan(
        model = PTM, slotData = slotData.block,
        slotOptions = slotOptions.mm, debug = FALSE, verbose = FALSE
      )
    } else if (FIT@Data@data.type == "moment") {
      slotOptions.mm$sample.cov.rescale <- FALSE
      fit.mm.block <- lavaan(
        model = PTM, slotData = slotData.block,
        sample.cov = mm.sample.cov, sample.mean = mm.sample.mean,
        sample.nobs = mm.sample.nobs,
        slotOptions = slotOptions.mm, debug = FALSE, verbose = FALSE
      )
    }

    # check convergence
    if (!lavInspect(fit.mm.block, "converged")) {
      # warning for now, but this is not good!
      lav_msg_warn(gettextf(
        "measurement model for %s did not converge!",
        lav_msg_view(mm.list[[mm]], "none")))
    }

    # store fitted measurement model
    MM.FIT[[mm]] <- fit.mm.block

    # fill in point estimates measurement block (including slack values)
    PTM <- MM.FIT[[mm]]@ParTable
    # pt.idx: the row-numbers in PT that correspond to the rows in PTM
    # pt.idx <- lav_partable_map_id_p1_in_p2(p1 = PTM, p2 = PT,
    #             stopifnotfound = TRUE, exclude.nonpar = FALSE)
    # pt.idx == mm.idx
    ptm.idx <- which((PTM$free > 0L | PTM$op %in% c(":=", "<", ">")) &
      PTM$user != 3L)
    block.ptm.idx[[mm]] <- ptm.idx
    PT$est[mm.idx[ptm.idx]] <- PTM$est[ptm.idx]

    # if categorical, add non-free residual variances
    if (fit.mm.block@Model@categorical || fit.mm.block@Model@correlation) {
      extra.idx <- which(PTM$op %in% c("~~", "~*~") &
        PTM$lhs == PTM$rhs &
        PTM$user == 0L &
        PTM$free == 0L &
        PTM$ustart == 1)
      if (length(extra.idx) > 0L) {
        PT$est[mm.idx[extra.idx]] <- PTM$est[extra.idx]
      }
    }
    # if EFA, add user=7 values (but do not add to ptm.idx)
    user7.idx <- which(PTM$user == 7L)
    if (length(user7.idx)) {
      PT$est[mm.idx[user7.idx]] <- PTM$est[user7.idx]
    }

    # add step1.free.idx
    par.idx <- PT.free[mm.idx[ptm.idx]]
    # store (ordered) indices in step1.free.idx
    this.mm.idx <- sort.int(par.idx)
    step1.free.idx <- c(step1.free.idx, this.mm.idx) # all combined


    # fill in standard errors measurement block
    if (!lavoptions$se %in% c("none", "bootstrap")) {
      if (fit.mm.block@Model@ceq.simple.only) {
        PTM.free <- PTM$free
        PTM.free[PTM.free > 0] <- seq_len(fit.mm.block@Model@nx.unco)
      } else {
        PTM.free <- PTM$free
      }

      ptm.se.idx <- which((PTM$free > 0L) & PTM$user != 3L) # no :=, <, >
      # PT$se[ seq_len(length(PT$lhs)) %in% mm.idx & PT$free > 0L ] <-
      #    PTM$se[ PTM$free > 0L & PTM$user != 3L]
      PT$se[mm.idx[ptm.se.idx]] <- PTM$se[ptm.se.idx]

      # compute variance matrix for this measurement block
      sigma.11 <- MM.FIT[[mm]]@vcov$vcov

      # fill in variance matrix
      keep.idx <- PTM.free[ptm.idx]
      # par.idx <- PT.free[ seq_len(length(PT$lhs)) %in% mm.idx &
      #                    PT$free > 0L ]
      # keep.idx <- PTM.free[ PTM$free > 0 & PTM$user != 3L ]
      Sigma.11[par.idx, par.idx] <-
        sigma.11[keep.idx, keep.idx, drop = FALSE]
    }
  } # measurement block

  # only keep 'measurement part' parameters in Sigma.11
  if (!lavoptions$se %in% c("none", "bootstrap")) {
    Sigma.11 <- Sigma.11[step1.free.idx, step1.free.idx, drop = FALSE]
  } else {
    Sigma.11 <- NULL
  }

  # create STEP1 list
  STEP1 <- list(
    MM.FIT = MM.FIT, Sigma.11 = Sigma.11,
    step1.free.idx = step1.free.idx,
    block.mm.idx = block.mm.idx,
    block.ptm.idx = block.ptm.idx,
    PT.free = PT.free,
    mm.list = mm.list, PT = PT
  )

  STEP1
}


# collect information about the model that we can use
# (eg. is theta diagonal or not, is the structurual model recursive or not,
#  is the model just a regression model, etc)
#
# initial version: YR 15 March 2021
# - YR 05 Oct 2021: use det(I - B) to check if B is acyclic
# - YR 11 Nov 2021: if no latents, and conditional.x = TRUE, we may have no
#                   beta matrix


# note: there is no 'lavmodel' yet, because we call this in lav_model.R
lav_model_properties <- function(GLIST, lavpartable = NULL,
                                 nmat = NULL, m.free.idx = NULL) {
  lavpta <- lav_partable_attributes(lavpartable)
  nblocks <- lavpta$nblocks

  # is the model a univariate/multivariate linear multiple regression
  # model (per block)?
  uvreg <- logical(nblocks)
  uvord <- logical(nblocks)
  mvreg <- logical(nblocks)
  acyclic <- rep(as.logical(NA), nblocks)
  bowfree <- rep(as.logical(NA), nblocks)
  nexo <- integer(nblocks)

  for (g in seq_len(nblocks)) {
    # at least 1 regression
    if (length(lavpta$vnames$eqs.y[[g]]) == 0L) {
      next
    }

    # find beta index for this block
    mm.in.block <- 1:nmat[g] + cumsum(c(0L, nmat))[g]
    MLIST <- GLIST[mm.in.block]
    beta.idx <- which(names(MLIST) == "beta") + cumsum(c(0L, nmat))[g]
    psi.idx <- which(names(MLIST) == "psi") + cumsum(c(0L, nmat))[g]

    if (length(beta.idx) > 0L) {
      # 1. acyclic?
      B <- GLIST[[beta.idx]]
      # keep fixed values (if any); fill in 1 in all 'free' positions
      B[m.free.idx[[beta.idx]]] <- 1
      IminB <- diag(nrow(B)) - B
      # if B is acyclic, we should be able to permute the rows/cols of B
      # so that B is upper/lower triangular, and so det(I-B) = 1
      if (det(IminB) == 1) {
        acyclic[g] <- TRUE
      } else {
        acyclic[g] <- FALSE
      }

      # 2. bow-free?
      B.one <- as.integer(B != 0)
      Psi <- GLIST[[psi.idx]]
      # keep fixed values (if any); fill in 1 in all 'free' positions
      Psi[m.free.idx[[psi.idx]]] <- 1
      Psi.one <- as.integer(Psi != 0)
      Both.one <- B.one + Psi.one
      if (any(Both.one > 1)) {
        bowfree[g] <- FALSE
      } else {
        bowfree[g] <- TRUE
      }
    } else {
      # perhaps conditional.x = TRUE?
      # if there is no BETA, then we only have Gamma, and the
      # system must be acyclic
      acyclic[g] <- TRUE
      # and also bowfree
      bowfree[g] <- TRUE
    }


    # no latent variables, at least 1 dependent variable
    if (lavpta$nfac[[g]] > 0L) {
      next
    }

    # no mediators
    if (length(lavpta$vnames$eqs.y[[g]]) !=
      length(lavpta$vnames$ov.y[[g]])) {
      next
    }

    # categorical y?
    if (length(lavpta$vnames$ov.ord[[g]]) > 0L) {
      # we only flag the univariate version
      if (length(lavpta$vnames$ov.ord[[g]]) == 1L &&
        length(lavpta$vnames$ov.y[[g]]) == 1L &&
        lavpta$vnames$ov.ord[[g]][1] == lavpta$vnames$ov.y[[g]][1]) {
        uvord[g] <- TRUE
      }

      # mvreg?
    } else {
      if (length(lavpta$vnames$ov.y[[g]]) > 1L) {
        mvreg[g] <- TRUE
      } else {
        uvreg[g] <- TRUE
      }
    }

    nexo[g] <- length(lavpta$vnames$eqs.x[[g]])
  } # g

  modprop <- list(
    uvreg = uvreg, uvord = uvord, mvreg = mvreg,
    nexo = nexo, acyclic = acyclic, bowfree = bowfree
  )

  modprop
}

# classic Wald test
#
# NOTE: does not handle redundant constraints yet!
#

lavTestWald <- function(object, constraints = NULL, verbose = FALSE) {
  # check object
  object <- lav_object_check_version(object)

  if (!missing(verbose)) {
    current.verbose <- lav_verbose()
    if (lav_verbose(verbose))
      on.exit(lav_verbose(current.verbose), TRUE)
  }
  if (object@optim$npar > 0L && !object@optim$converged) {
    lav_msg_stop(gettext("model did not converge"))
  }

  if (is.null(constraints) || all(nchar(constraints) == 0L)) {
    lav_msg_stop(gettext("constraints are empty"))
  }

  # extract slots
  lavoptions <- object@Options
  lavmodel <- object@Model
  lavpartable <- data.frame(object@ParTable)

  # remove == constraints from parTable
  eq.idx <- which(lavpartable$op == "==")
  if (length(eq.idx) > 0L) {
    lavpartable <- lavpartable[-eq.idx, ]
  }
  partable <- as.list(lavpartable)

  # parse constraints
  FLAT <- lavParseModelString(constraints, parser = lavoptions$parser)
  CON <- attr(FLAT, "constraints")
  LIST <- list()
  if (length(CON) > 0L) {
    lhs <- unlist(lapply(CON, "[[", "lhs"))
    op <- unlist(lapply(CON, "[[", "op"))
    rhs <- unlist(lapply(CON, "[[", "rhs"))
    LIST$lhs <- c(LIST$lhs, lhs)
    LIST$op <- c(LIST$op, op)
    LIST$rhs <- c(LIST$rhs, rhs)
  } else {
    lav_msg_stop(gettext(
      "no equality constraints found in constraints argument"))
  }

  # theta = free parameters only
  theta <- lav_model_get_parameters(lavmodel)

  # build constraint function
  ceq.function <- lav_partable_constraints_ceq(
    partable = partable,
    con = LIST, debug = FALSE
  )
  # compute jacobian restrictions
  JAC <- try(lav_func_jacobian_complex(func = ceq.function, x = theta),
    silent = TRUE
  )
  if (inherits(JAC, "try-error")) { # eg. pnorm()
    JAC <- lav_func_jacobian_simple(func = ceq.function, x = theta)
  }

  # check for linear redundant rows in JAC
  out <- lav_matrix_rref(t(JAC))
  ranK <- length(out$pivot)
  if (ranK < nrow(JAC)) {
    lav_msg_warn(gettext("Jacobian of constraints is rank deficient. Some constraints may be redundant, and have been removed."))
  }
  JAC <- JAC[out$pivot, , drop = FALSE]

  if (lav_verbose()) {
    cat("Restriction matrix (jacobian):\n")
    print(JAC)
    cat("\n")
  }

  # linear restriction
  theta.r <- ceq.function(theta)
  theta.r <- theta.r[out$pivot]

  if (lav_verbose()) {
    cat("Restricted theta values:\n")
    print(theta.r)
    cat("\n")
  }

  # get VCOV
  # VCOV <- vcov(object, labels = FALSE)
  # avoid S4 dispatch
  VCOV <- lav_object_inspect_vcov(object,
    standardized = FALSE,
    free.only = TRUE,
    add.labels = FALSE,
    add.class = FALSE,
    remove.duplicated = FALSE
  )

  # restricted vcov
  VCOV.r <- JAC %*% VCOV %*% t(JAC)

  # fixme: what if VCOV.r is singular?
  # Wald test statistic
  Wald <- as.numeric(t(theta.r) %*% solve(VCOV.r) %*% theta.r)

  # df
  Wald.df <- ranK

  # p-value based on chisq
  Wald.pvalue <- 1 - pchisq(Wald, df = Wald.df)

  # prepare output
  out <- list(
    stat = Wald, df = Wald.df, p.value = Wald.pvalue,
    se = lavoptions$se
  )

  out
}

# the weighted bivariate ordinal model
# YR 19 Feb 2020 (replacing the old lav_polychor.R routines)
#
# - polychoric (and tetrachoric) correlations
# - bivariate ordinal regression
# - using sampling weights wt

# two-way frequency table
# only works if Y = 1,2,3,...
lav_bvord_freq <- function(Y1, Y2, wt = NULL) {
  max.y1 <- max(Y1, na.rm = TRUE)
  max.y2 <- max(Y2, na.rm = TRUE)

  bin <- Y1 - 1L
  bin <- bin + max.y1 * (Y2 - 1L)
  bin <- bin + 1L

  if (is.null(wt)) {
    bin <- bin[!is.na(bin)]
    out <- array(tabulate(bin, nbins = max.y1 * max.y2),
      dim = c(max.y1, max.y2)
    )
  } else {
    if (anyNA(Y1) || anyNA(Y2)) {
      wt[is.na(Y1) | is.na(Y2)] <- 0
      bin[is.na(bin)] <- 0
    }
    y.ncat <- max.y1 * max.y2
    y.freq <- numeric(y.ncat)
    for (cat in seq_len(y.ncat)) {
      y.freq[cat] <- sum(wt[bin == cat])
    }
    out <- array(y.freq, dim = c(max.y1, max.y2))
  }

  out
}

# polychoric correlation
#
# zero.add is a vector: first element is for 2x2 tables only, second element
#                       for general tables
# zero.keep.margins is only used for 2x2 tables
#
lav_bvord_cor_twostep_fit <- function(Y1, Y2, eXo = NULL, wt = NULL,
                                      fit.y1 = NULL, fit.y2 = NULL,
                                      freq = NULL,
                                      zero.add = c(0.5, 0.0),
                                      zero.keep.margins = TRUE,
                                      zero.cell.warn = FALSE,
                                      zero.cell.flag = FALSE,
                                      optim.method = "nlminb2",
                                      optim.scale = 1.0,
                                      init.theta = NULL,
                                      control = list(step.min = 0.1), # 0.6-7
                                      Y1.name = NULL, Y2.name = NULL) {
  if (is.null(fit.y1)) {
    fit.y1 <- lav_uvord_fit(y = Y1, X = eXo, wt = wt)
  }
  if (is.null(fit.y2)) {
    fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt)
  }

  # create cache environment
  cache <- lav_bvord_init_cache(fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt)

  # empty cells or not
  empty.cells <- FALSE

  # check for zero cells (if not exo), and catch some special cases
  if (cache$nexo == 0L) {
    freq <- cache$freq
    nr <- nrow(freq)
    nc <- ncol(freq)

    # check for empty cells
    if (any(freq == 0L)) {
      empty.cells <- TRUE
      if (zero.cell.warn) {
        if (!is.null(Y1.name) && !is.null(Y2.name)) {
          lav_msg_warn(gettextf(
            "empty cell(s) in bivariate table of %1$s x %2$s",
            Y1.name, Y2.name))
        } else {
          lav_msg_warn(gettext("empty cell(s) in bivariate table"))
        }
      }
    }

    # treat 2x2 tables
    if (nr == 2L && nc == 2L) {
      idx <- which(freq == 0L)
      # catch 2 empty cells: perfect correlation!
      if (length(idx) == 2L) {
        lav_msg_warn(gettext("two empty cells in 2x2 table"))
        if (freq[1, 1] > 0L) {
          rho <- 1.0
          if (zero.cell.flag) {
            attr(rho, "zero.cell.flag") <- empty.cells
          }
          return(rho)
        } else {
          rho <- -1.0
          if (zero.cell.flag) {
            attr(rho, "zero.cell.flag") <- empty.cells
          }
          return(rho)
        }
      } else if (length(idx) == 1L && zero.add[1] > 0.0) {
        if (zero.keep.margins) {
          # add + compensate to preserve margins
          if (idx == 1L || idx == 4L) { # main diagonal
            freq[1, 1] <- freq[1, 1] + zero.add[1]
            freq[2, 2] <- freq[2, 2] + zero.add[1]
            freq[2, 1] <- freq[2, 1] - zero.add[1]
            freq[1, 2] <- freq[1, 2] - zero.add[1]
          } else {
            freq[1, 1] <- freq[1, 1] - zero.add[1]
            freq[2, 2] <- freq[2, 2] - zero.add[1]
            freq[2, 1] <- freq[2, 1] + zero.add[1]
            freq[1, 2] <- freq[1, 2] + zero.add[1]
          }
        } else {
          freq[idx] <- freq[idx] + zero.add[1]
        }
      }
      # general table
    } else {
      if (any(freq == 0L) && zero.add[2] > 0.0) {
        # general table: just add zero.add to the empty cell(s)
        freq[freq == 0] <- zero.add[2]
      }
    }

    # update (possibly change) freq table
    cache$freq <- freq

    # catch special cases for 2x2 tables
    if (nr == 2L && nc == 2L) {
      # 1. a*d == c*d
      storage.mode(freq) <- "numeric" # to avoid integer overflow
      if (freq[1, 1] * freq[2, 2] == freq[1, 2] * freq[2, 1]) {
        rho <- 0.0
        if (zero.cell.flag) {
          attr(rho, "zero.cell.flag") <- empty.cells
        }
        return(rho)
      }
      # 2. equal margins (th1 = th2 = 0)
      if (cache$th.y1[1] == 0 && cache$th.y2[1] == 0) {
        # see eg Brown & Benedetti 1977 eq 2
        rho <- -cos(2 * pi * freq[1, 1] / sum(freq))
        if (zero.cell.flag) {
          attr(rho, "zero.cell.flag") <- empty.cells
        }
        return(rho)
      }
    }
  } # non-exo

  # optim.method
  minObjective <- lav_bvord_min_objective
  minGradient <- lav_bvord_min_gradient
  minHessian <- lav_bvord_min_hessian
  if (optim.method == "nlminb" || optim.method == "nlminb2") {
    # nothing to do
  } else if (optim.method == "nlminb0") {
    minGradient <- minHessian <- NULL
  } else if (optim.method == "nlminb1") {
    minHessian <- NULL
  }

  # optimize
  if (is.null(control$trace)) {
    control$trace <- ifelse(lav_verbose(), 1, 0)
  }

  # init theta?
  if (!is.null(init.theta)) {
    start.x <- init.theta
  } else {
    start.x <- cache$theta
  }

  # try 1
  optim <- nlminb(
    start = start.x, objective = minObjective,
    gradient = minGradient, hessian = minHessian,
    control = control,
    scale = optim.scale, lower = -0.999, upper = +0.999,
    cache = cache
  )

  # try 2
  if (optim$convergence != 0L) {
    # try again, with different starting value
    optim <- nlminb(
      start = 0, objective = minObjective,
      gradient = NULL, hessian = NULL,
      control = control,
      scale = optim.scale, lower = -0.995, upper = +0.995,
      cache = cache
    )
  }

  # check convergence
  if (optim$convergence != 0L) {
    if (!is.null(Y1.name) && !is.null(Y2.name)) {
      lav_msg_warn(gettextf(
        "estimation polychoric correlation did not converge for
                    variables %1$s and %2$s", Y1.name, Y2.name))
    } else {
      lav_msg_warn(gettext(
        "estimation polychoric correlation(s) did not always converge"))
    }
    rho <- start.x
  } else {
    rho <- optim$par
  }

  # zero.cell.flag
  if (zero.cell.flag) {
    attr(rho, "zero.cell.flag") <- empty.cells
  }

  rho
}


# prepare cache environment
lav_bvord_init_cache <- function(fit.y1 = NULL,
                                 fit.y2 = NULL,
                                 wt = NULL,
                                 scores = FALSE,
                                 parent = parent.frame()) {
  # data
  Y1 <- fit.y1$y
  Y2 <- fit.y2$y
  eXo <- fit.y1$X

  # exo?
  if (is.null(eXo)) {
    nexo <- 0L
    freq <- lav_bvord_freq(Y1 = Y1, Y2 = Y2, wt = wt)
    th.y1 <- fit.y1$theta[fit.y1$th.idx]
    th.y2 <- fit.y2$theta[fit.y2$th.idx]
    nth.y1 <- length(th.y1)
    nth.y2 <- length(th.y2)
    pth.y1 <- pnorm(th.y1)
    pth.y2 <- pnorm(th.y2)
    upper.y <- rep(th.y2, times = rep.int(nth.y1, nth.y2))
    upper.x <- rep(th.y1, times = ceiling(length(upper.y)) / nth.y1)
  } else {
    nexo <- ncol(eXo)
    freq <- NULL
    fit.y1.z1 <- fit.y1$z1
    fit.y2.z1 <- fit.y2$z1
    fit.y1.z2 <- fit.y1$z2
    fit.y2.z2 <- fit.y2$z2

    # take care of missing values
    if (length(fit.y1$missing.idx) > 0L || length(fit.y2$missing.idx) > 0L) {
      missing.idx <- unique(c(fit.y1$missing.idx, fit.y2$missing.idx))
      fit.y1.z1[missing.idx] <- 0
      fit.y2.z1[missing.idx] <- 0
      fit.y1.z2[missing.idx] <- 0
      fit.y2.z2[missing.idx] <- 0
    } else {
      missing.idx <- integer(0L)
    }
  }

  # nobs
  if (is.null(wt)) {
    N <- length(Y1)
  } else {
    N <- sum(wt)
  }

  # starting value (for both exo and not-exo)
  # if(is.null(wt)) {
  if(sd(Y1, na.rm = TRUE) == 0 || sd(Y2, na.rm = TRUE) == 0) {
    rho.init <- 0.0
  } else {
    rho.init <- cor(Y1, Y2, use = "pairwise.complete.obs")
  }
  # }
  # cov.wt does not handle missing values...
  # rho.init <- cov.wt(cbind(Y1, Y2), wt = wt, cor = TRUE)$cor[2,1]
  if (is.na(rho.init) || abs(rho.init) >= 1.0) {
    rho.init <- 0.0
  }

  # parameter vector
  theta <- rho.init # only, for now

  # different cache if exo or not
  if (nexo == 0L) {
    if (scores) {
      out <- list2env(
        list(
          nexo = nexo, theta = theta, N = N,
          fit.y1.z1 = fit.y1$z1, fit.y1.z2 = fit.y1$z2,
          fit.y2.z1 = fit.y2$z1, fit.y2.z2 = fit.y2$z2,
          y1.Y1 = fit.y1$Y1, y1.Y2 = fit.y1$Y2,
          y2.Y1 = fit.y2$Y1, y2.Y2 = fit.y2$Y2,
          Y1 = Y1, Y2 = Y2, freq = freq,
          th.y1 = th.y1, th.y2 = th.y2,
          nth.y1 = nth.y1, nth.y2 = nth.y2,
          pth.y1 = pth.y1, pth.y2 = pth.y2,
          upper.y = upper.y, upper.x = upper.x
        ),
        parent = parent
      )
    } else {
      out <- list2env(
        list(
          nexo = nexo, theta = theta, N = N,
          Y1 = Y1, Y2 = Y2, freq = freq,
          th.y1 = th.y1, th.y2 = th.y2,
          nth.y1 = nth.y1, nth.y2 = nth.y2,
          pth.y1 = pth.y1, pth.y2 = pth.y2,
          upper.y = upper.y, upper.x = upper.x
        ),
        parent = parent
      )
    }
  } else {
    if (scores) {
      out <- list2env(
        list(
          nexo = nexo, theta = theta, wt = wt, N = N,
          eXo = eXo,
          y1.Y1 = fit.y1$Y1, y1.Y2 = fit.y1$Y2,
          y2.Y1 = fit.y2$Y1, y2.Y2 = fit.y2$Y2,
          fit.y1.z1 = fit.y1.z1, fit.y1.z2 = fit.y1.z2,
          fit.y2.z1 = fit.y2.z1, fit.y2.z2 = fit.y2.z2,
          missing.idx = missing.idx
        ),
        parent = parent
      )
    } else {
      out <- list2env(
        list(
          nexo = nexo, theta = theta, wt = wt, N = N,
          fit.y1.z1 = fit.y1.z1, fit.y1.z2 = fit.y1.z2,
          fit.y2.z1 = fit.y2.z1, fit.y2.z2 = fit.y2.z2,
          missing.idx = missing.idx
        ),
        parent = parent
      )
    }
  }

  out
}

# probabilities for each cell, given rho, th.y1 and th.y2
lav_bvord_noexo_pi_cache <- function(cache = NULL) {
  with(cache, {
    rho <- theta[1L]

    # catch special case: rho = 0.0
    if (rho == 0.0) {
      rowPI <- base::diff(c(0, pth.y1, 1))
      colPI <- base::diff(c(0, pth.y2, 1))
      PI.ij <- base::outer(rowPI, colPI)
      return(PI.ij)
    }

    BI <- pbivnorm::pbivnorm(x = upper.x, y = upper.y, rho = rho)
    dim(BI) <- c(nth.y1, nth.y2)
    BI <- rbind(0, BI, pth.y2, deparse.level = 0L)
    BI <- cbind(0, BI, c(0, pth.y1, 1), deparse.level = 0L)

    # get probabilities
    nr <- nrow(BI)
    nc <- ncol(BI)
    PI <- BI[-1L, -1L] - BI[-1L, -nc] - BI[-nr, -1L] + BI[-nr, -nc]

    # all elements should be strictly positive
    PI[PI < sqrt(.Machine$double.eps)] <- sqrt(.Machine$double.eps)

    return(PI)
  })
}

# partial derivative of CDF(th.y1, th.y2, rho) with respect to rho
lav_bvord_noexo_phi_cache <- function(cache = NULL) {
  with(cache, {
    rho <- theta[1L]

    # compute lav_dbinorm for all possible combinations
    t1 <- rep(th.y1, times = nth.y2)
    t2 <- rep(th.y2, each = nth.y1)
    dbiNorm <- matrix(lav_dbinorm(t1, t2, rho),
      nrow = nth.y1, ncol = nth.y2
    )

    p1 <- p2 <- p3 <- p4 <- matrix(0, nth.y1 + 1L, nth.y2 + 1L)
    t1.idx <- seq_len(nth.y1)
    t2.idx <- seq_len(nth.y2)

    # p1 is left-upper corner
    p1[t1.idx, t2.idx] <- dbiNorm
    # p2 is left-lower corner
    p2[t1.idx + 1L, t2.idx] <- dbiNorm
    # p3 is right-upper corner
    p3[t1.idx, t2.idx + 1L] <- dbiNorm
    # p3 is right-lower corner
    p4[t1.idx + 1L, t2.idx + 1L] <- dbiNorm

    phi <- p1 - p2 - p3 + p4
    return(phi)
  })
}

# Olsson 1979 A2
lav_bvord_noexo_gnorm_cache <- function(cache = NULL) {
  with(cache, {
    rho <- theta[1L]

    # note: Olsson 1979 A2 contains an error!!
    # derivative of phi_2(y1,y2;rho) wrt to rho equals
    # phi_2(y1,y2;rho) * guv(y1,y2;rho), where guv() is defined below:
    guv <- function(u, v, rho) {
      R <- (1 - rho * rho)
      (u * v * R - rho * ((u * u) - 2 * rho * u * v + (v * v)) + rho * R) / (R * R)
    }

    # compute gnorm for all possible combinations
    Gnorm <- dbiNorm * matrix(guv(t1, t2, rho), nth.y1, nth.y2)

    p1 <- p2 <- p3 <- p4 <- matrix(0, nth.y1 + 1L, nth.y2 + 1L)
    t1.idx <- seq_len(nth.y1)
    t2.idx <- seq_len(nth.y2)

    # p1 is left-upper corner
    p1[t1.idx, t2.idx] <- Gnorm
    # p2 is left-lower corner
    p2[t1.idx + 1L, t2.idx] <- Gnorm
    # p3 is right-upper corner
    p3[t1.idx, t2.idx + 1L] <- Gnorm
    # p3 is right-lower corner
    p4[t1.idx + 1L, t2.idx + 1L] <- Gnorm

    gnorm <- p1 - p2 - p3 + p4
    return(gnorm)
  })
}


# casewise likelihoods, unweighted!
lav_bvord_lik_cache <- function(cache = NULL) {
  with(cache, {
    rho <- theta[1L]

    # no exo
    if (nexo == 0L) {
      PI <- lav_bvord_noexo_pi_cache(cache)
      lik <- PI[cbind(Y1, Y2)]

      # exo
    } else {
      lik <- pbinorm(
        upper.x = fit.y1.z1, upper.y = fit.y2.z1,
        lower.x = fit.y1.z2, lower.y = fit.y2.z2, rho = rho
      )
      if (length(missing.idx) > 0L) {
        lik[missing.idx] <- NA
      }
      # catch very small values
      lik.toosmall.idx <- which(lik < sqrt(.Machine$double.eps))
      lik[lik.toosmall.idx] <- as.numeric(NA)
    }

    return(lik)
  })
}

lav_bvord_logl_cache <- function(cache = NULL) {
  with(cache, {
    rho <- theta[1L]

    # no exo
    if (nexo == 0L) {
      PI <- lav_bvord_noexo_pi_cache(cache)
      logl <- sum(freq * log(PI), na.rm = TRUE)

      # exo
    } else {
      lik <- lav_bvord_lik_cache(cache) # unweighted!
      if (!is.null(wt)) {
        logl <- sum(wt * log(lik), na.rm = TRUE)
      } else {
        logl <- sum(log(lik), na.rm = TRUE)
      }
    }

    return(logl)
  })
}

lav_bvord_gradient_cache <- function(cache = NULL) {
  with(cache, {
    rho <- theta[1L]

    # no exo
    if (nexo == 0L) {
      phi <- lav_bvord_noexo_phi_cache(cache)
      bad.idx <- which(PI <= sqrt(.Machine$double.eps))
      if (length(bad.idx) > 0L) {
        PI[bad.idx] <- as.numeric(NA)
      }
      dx.rho <- sum((freq * phi) / PI, na.rm = TRUE)

      # exo
    } else {
      d1 <- lav_dbinorm(fit.y1.z1, fit.y2.z1, rho)
      d2 <- lav_dbinorm(fit.y1.z2, fit.y2.z1, rho)
      d3 <- lav_dbinorm(fit.y1.z1, fit.y2.z2, rho)
      d4 <- lav_dbinorm(fit.y1.z2, fit.y2.z2, rho)
      phi <- (d1 - d2 - d3 + d4)

      # avoid dividing by very tine numbers (new in 0.6-6)
      # -> done automatically: lik == NA in this case
      # bad.idx <- which(lik <= sqrt(.Machine$double.eps))
      # if(length(bad.idx) > 0L) {
      #    lik[bad.idx] <- as.numeric(NA)
      # }

      dx2 <- phi / lik

      if (is.null(wt)) {
        dx.rho <- sum(dx2, na.rm = TRUE)
      } else {
        dx.rho <- sum(wt * dx2, na.rm = TRUE)
      }
    }

    return(dx.rho)
  })
}

lav_bvord_hessian_cache <- function(cache = NULL) {
  with(cache, {
    rho <- theta[1L]

    # no exo
    if (nexo == 0L) {
      bad.idx <- which(PI <= sqrt(.Machine$double.eps))
      if (length(bad.idx) > 0L) {
        PI[bad.idx] <- as.numeric(NA)
      }
      gnorm <- lav_bvord_noexo_gnorm_cache(cache)
      # H <- sum( freq * (gnorm/PI - (phi*phi)/(PI*PI)), na.rm = TRUE)
      H <- (sum((freq * gnorm) / PI, na.rm = TRUE) -
        sum((freq * phi * phi) / (PI * PI), na.rm = TRUE))
      dim(H) <- c(1L, 1L)

      # exo
    } else {
      guv <- function(u, v, rho) {
        R <- (1 - rho * rho)
        (u * v * R - rho * ((u * u) - 2 * rho * u * v + (v * v)) + rho * R) / (R * R)
      }

      gnorm <- ((d1 * guv(fit.y1.z1, fit.y2.z1, rho)) -
        (d2 * guv(fit.y1.z2, fit.y2.z1, rho)) -
        (d3 * guv(fit.y1.z1, fit.y2.z2, rho)) +
        (d4 * guv(fit.y1.z2, fit.y2.z2, rho)))

      if (is.null(wt)) {
        H <- sum(gnorm / lik - (phi * phi) / (lik * lik), na.rm = TRUE)
      } else {
        H <- sum(wt * (gnorm / lik - (phi * phi) / (lik * lik)), na.rm = TRUE)
      }

      dim(H) <- c(1L, 1L)
    }

    return(H)
  })
}



# compute total (log)likelihood, for specific 'x' (nlminb)
lav_bvord_min_objective <- function(x, cache = NULL) {
  cache$theta <- x
  -1 * lav_bvord_logl_cache(cache = cache) / cache$N
}

# compute gradient, for specific 'x' (nlminb)
lav_bvord_min_gradient <- function(x, cache = NULL) {
  # check if x has changed
  if (!all(x == cache$theta)) {
    cache$theta <- x
    tmp <- lav_bvord_logl_cache(cache = cache)
  }
  -1 * lav_bvord_gradient_cache(cache = cache) / cache$N
}

# compute hessian, for specific 'x' (nlminb)
lav_bvord_min_hessian <- function(x, cache = NULL) {
  # check if x has changed
  if (!all(x == cache$theta)) {
    cache$theta <- x
    tmp <- lav_bvord_logl_cache(cache = cache)
    tmp <- lav_bvord_gradient_cache(cache = cache)
  }
  -1 * lav_bvord_hessian_cache(cache = cache) / cache$N
}




# casewise scores
lav_bvord_cor_scores_cache <- function(cache = NULL, na.zero = FALSE,
                                       use.weights = TRUE) {
  with(cache, {
    rho <- theta[1L]
    R <- sqrt(1 - rho * rho)

    # lik
    lik <- lav_bvord_lik_cache(cache = cache)
    bad.idx <- which(lik <= sqrt(.Machine$double.eps))
    if (length(bad.idx) > 0L) {
      lik[bad.idx] <- as.numeric(NA)
    }

    d.y1.z1 <- dnorm(fit.y1.z1)
    d.y1.z2 <- dnorm(fit.y1.z2)
    d.y2.z1 <- dnorm(fit.y2.z1)
    d.y2.z2 <- dnorm(fit.y2.z2)

    # th.y1
    if (identical(R, 0.0)) {
      y1.Z1 <- d.y1.z1 * 0.5
      y1.Z2 <- d.y1.z2 * 0.5
    } else {
      y1.Z1 <- (d.y1.z1 * pnorm((fit.y2.z1 - rho * fit.y1.z1) / R) -
        d.y1.z1 * pnorm((fit.y2.z2 - rho * fit.y1.z1) / R))
      y1.Z2 <- (d.y1.z2 * pnorm((fit.y2.z1 - rho * fit.y1.z2) / R) -
        d.y1.z2 * pnorm((fit.y2.z2 - rho * fit.y1.z2) / R))
    }
    dx.th.y1 <- (y1.Y1 * y1.Z1 - y1.Y2 * y1.Z2) / lik
    if (na.zero) {
      dx.th.y1[is.na(dx.th.y1)] <- 0
    }

    # th.y2
    if (identical(R, 0.0)) {
      y2.Z1 <- d.y2.z1 * 0.5
      y2.Z2 <- d.y2.z2 * 0.5
    } else {
      y2.Z1 <- (d.y2.z1 * pnorm((fit.y1.z1 - rho * fit.y2.z1) / R) -
        d.y2.z1 * pnorm((fit.y1.z2 - rho * fit.y2.z1) / R))
      y2.Z2 <- (d.y2.z2 * pnorm((fit.y1.z1 - rho * fit.y2.z2) / R) -
        d.y2.z2 * pnorm((fit.y1.z2 - rho * fit.y2.z2) / R))
    }
    dx.th.y2 <- (y2.Y1 * y2.Z1 - y2.Y2 * y2.Z2) / lik
    if (na.zero) {
      dx.th.y2[is.na(dx.th.y2)] <- 0
    }

    # slopes
    dx.sl.y1 <- dx.sl.y2 <- NULL
    if (nexo > 0L) {
      # sl.y1
      dx.sl.y1 <- (y1.Z2 - y1.Z1) * eXo / lik
      if (na.zero) {
        dx.sl.y1[is.na(dx.sl.y1)] <- 0
      }

      # sl.y2
      dx.sl.y2 <- (y2.Z2 - y2.Z1) * eXo / lik
      if (na.zero) {
        dx.sl.y2[is.na(dx.sl.y2)] <- 0
      }
    }

    # rho
    if (nexo == 0L) {
      phi <- lav_bvord_noexo_phi_cache(cache)
      dx <- phi[cbind(Y1, Y2)]
    } else {
      dx <- (lav_dbinorm(fit.y1.z1, fit.y2.z1, rho) -
        lav_dbinorm(fit.y1.z2, fit.y2.z1, rho) -
        lav_dbinorm(fit.y1.z1, fit.y2.z2, rho) +
        lav_dbinorm(fit.y1.z2, fit.y2.z2, rho))
    }
    dx.rho <- dx / lik
    if (na.zero) {
      dx.rho[is.na(dx.rho)] <- 0
    }

    if (!is.null(wt) && use.weights) {
      dx.th.y1 <- dx.th.y1 * wt
      dx.th.y2 <- dx.th.y2 * wt
      if (nexo > 0L) {
        dx.sl.y1 <- dx.sl.y1 * wt
        dx.sl.y2 <- dx.sl.y2 * wt
      }
      dx.rho <- dx.rho * wt
    }

    out <- list(
      dx.th.y1 = dx.th.y1, dx.th.y2 = dx.th.y2,
      dx.sl.y1 = dx.sl.y1, dx.sl.y2 = dx.sl.y2, dx.rho = dx.rho
    )
    return(out)
  })
}


# casewise scores - no cache
lav_bvord_cor_scores <- function(Y1, Y2, eXo = NULL, wt = NULL,
                                 rho = NULL,
                                 fit.y1 = NULL, fit.y2 = NULL,
                                 th.y1 = NULL, th.y2 = NULL,
                                 sl.y1 = NULL, sl.y2 = NULL,
                                 na.zero = FALSE, use.weights = TRUE) {
  if (is.null(fit.y1)) {
    fit.y1 <- lav_uvord_fit(y = Y1, X = eXo, wt = wt)
  }
  if (is.null(fit.y2)) {
    fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt)
  }

  # update z1/z2 if needed (used in lav_pml_dploglik_dimplied() in lav_model_gradient_pml.R)
  fit.y1 <- lav_uvord_update_fit(
    fit.y = fit.y1,
    th.new = th.y1, sl.new = sl.y1
  )
  fit.y2 <- lav_uvord_update_fit(
    fit.y = fit.y2,
    th.new = th.y2, sl.new = sl.y2
  )

  # create cache environment
  cache <- lav_bvord_init_cache(
    fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt,
    scores = TRUE
  )
  cache$theta <- rho

  SC <- lav_bvord_cor_scores_cache(
    cache = cache, na.zero = na.zero,
    use.weights = use.weights
  )

  SC
}

# logl - no cache
lav_bvord_logl <- function(Y1, Y2, eXo = NULL, wt = NULL,
                           rho = NULL,
                           fit.y1 = NULL, fit.y2 = NULL,
                           th.y1 = NULL, th.y2 = NULL,
                           sl.y1 = NULL, sl.y2 = NULL) {
  if (is.null(fit.y1)) {
    fit.y1 <- lav_uvord_fit(y = Y1, X = eXo, wt = wt)
  }
  if (is.null(fit.y2)) {
    fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt)
  }

  # update z1/z2 if needed (used in lav_pml_dploglik_dimplied() in lav_model_gradient_pml.R)
  fit.y1 <- lav_uvord_update_fit(
    fit.y = fit.y1,
    th.new = th.y1, sl.new = sl.y1
  )
  fit.y2 <- lav_uvord_update_fit(
    fit.y = fit.y2,
    th.new = th.y2, sl.new = sl.y2
  )

  # create cache environment
  cache <- lav_bvord_init_cache(fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt)
  cache$theta <- rho

  lav_bvord_logl_cache(cache = cache)
}

# lik - no cache
lav_bvord_lik <- function(Y1, Y2, eXo = NULL, wt = NULL,
                          rho = NULL,
                          fit.y1 = NULL, fit.y2 = NULL,
                          th.y1 = NULL, th.y2 = NULL,
                          sl.y1 = NULL, sl.y2 = NULL,
                          .log = FALSE) {
  if (is.null(fit.y1)) {
    fit.y1 <- lav_uvord_fit(y = Y1, X = eXo, wt = wt)
  }
  if (is.null(fit.y2)) {
    fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt)
  }

  # update fit.y1/fit.y2
  fit.y1 <- lav_uvord_update_fit(
    fit.y = fit.y1,
    th.new = th.y1, sl.new = sl.y1
  )
  fit.y2 <- lav_uvord_update_fit(
    fit.y = fit.y2,
    th.new = th.y2, sl.new = sl.y2
  )

  # create cache environment
  cache <- lav_bvord_init_cache(fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt)
  cache$theta <- rho

  lik <- lav_bvord_lik_cache(cache = cache) # unweighted
  if (.log) {
    lik <- log(lik)
  }

  if (!is.null(wt)) {
    if (.log) {
      lik <- wt * lik
    } else {
      tmp <- wt * log(lik)
      lik <- exp(tmp)
    }
  }

  lik
}

# noexo_pi - for backwards compatibility
lav_bvord_noexo_pi <- function(rho = NULL, th.y1 = NULL, th.y2 = NULL) {
  nth.y1 <- length(th.y1)
  nth.y2 <- length(th.y2)
  pth.y1 <- pnorm(th.y1)
  pth.y2 <- pnorm(th.y2)

  # catch special case: rho = 0.0
  if (rho == 0.0) {
    rowPI <- base::diff(c(0, pth.y1, 1))
    colPI <- base::diff(c(0, pth.y2, 1))
    PI.ij <- base::outer(rowPI, colPI)
    return(PI.ij)
  }

  # prepare for a single call to pbinorm
  upper.y <- rep(th.y2, times = rep.int(nth.y1, nth.y2))
  upper.x <- rep(th.y1, times = ceiling(length(upper.y)) / nth.y1)
  # rho <- rep(rho, length(upper.x)) # only one rho here

  BI <- pbivnorm::pbivnorm(x = upper.x, y = upper.y, rho = rho)
  dim(BI) <- c(nth.y1, nth.y2)
  BI <- rbind(0, BI, pth.y2, deparse.level = 0L)
  BI <- cbind(0, BI, c(0, pth.y1, 1), deparse.level = 0L)

  # get probabilities
  nr <- nrow(BI)
  nc <- ncol(BI)
  PI <- BI[-1L, -1L] - BI[-1L, -nc] - BI[-nr, -1L] + BI[-nr, -nc]

  # all elements should be strictly positive
  PI[PI < sqrt(.Machine$double.eps)] <- sqrt(.Machine$double.eps)
  PI
}

lav_samplestats_step1 <- function(Y,
                                  wt = NULL, # new in 0.6-6
                                  ov.names = NULL,
                                  ov.types = NULL,
                                  ov.levels = NULL,
                                  ov.names.x = character(0L),
                                  eXo = NULL,
                                  scores.flag = TRUE, # scores?
                                  allow.empty.cell = TRUE, # allow empty categories?
                                  group = 1L) { # for error message


  # just in case Y is a vector
  Y <- as.matrix(Y)

  nvar <- NCOL(Y)
  N <- NROW(Y)
  nTH <- ov.levels - 1L
  nTH[nTH == -1L] <- 1L
  nth <- sum(nTH)
  th.end.idx <- cumsum(nTH)
  th.start.idx <- th.end.idx - (nTH - 1L)

  # variable types; default = numeric
  nexo <- length(ov.names.x)
  if (nexo > 0L) stopifnot(NCOL(eXo) == nexo)

  # means/thresholds/intercepts, slopes, variances
  TH <- vector("list", length = nvar)
  TH.NOX <- vector("list", length = nvar)
  TH.NAMES <- vector("list", length = nvar)
  TH.IDX <- vector("list", length = nvar)
  SLOPES <- matrix(as.numeric(NA), nrow = nvar, ncol = nexo) # if conditional.x
  VAR <- numeric(length = nvar) # continuous variables only

  # SCORES
  SC.VAR <- matrix(0, N, nvar)
  SC.SL <- matrix(0, N, nvar * nexo)
  SC.TH <- matrix(0, N, nth)

  # fitted objects
  FIT <- vector("list", length = nvar)

  # stage one - TH/SLOPES/VAR only
  for (i in 1:nvar) {
    th.idx <- th.start.idx[i]:th.end.idx[i]
    sl.idx <- seq(i, by = nvar, length.out = nexo)
    if (ov.types[i] == "numeric") {
      fit <- lav_uvreg_fit(y = Y[, i], X = eXo, wt = wt)
      if (any(is.na(fit$theta))) {
        lav_msg_stop(gettextf(
          "linear regression failed for %1$s;
          X may not be of full rank in group %2$s", ov.names[i], group))
      }
      FIT[[i]] <- fit
      # compute mean and variance
      TH[[i]] <- TH.NOX[[i]] <- fit$theta[1L]
      VAR[i] <- fit$theta[fit$var.idx]
      TH.NAMES[[i]] <- ov.names[i]
      TH.IDX[[i]] <- 0L
      if (scores.flag) {
        scores <- lav_uvreg_scores(y = Y[, i], X = eXo, wt = wt)
        SC.TH[, th.idx] <- scores[, 1L]
        SC.VAR[, i] <- scores[, fit$var.idx]
      }
      if (nexo > 0L) {
        SLOPES[i, ] <- fit$theta[-c(1L, fit$var.idx)]
        if (scores.flag) {
          SC.SL[, sl.idx] <- scores[, -c(1L, fit$var.idx), drop = FALSE]
        }
        TH.NOX[[i]] <- mean(Y[, i], na.rm = TRUE)
      }
    } else if (ov.types[i] == "ordered") {
      # check if we have enough categories in this group
      # FIXME: should we more tolerant here???
      y.freq <- tabulate(Y[, i], nbins = ov.levels[i])
      if (length(y.freq) != ov.levels[i] & !allow.empty.cell) {
        lav_msg_stop(gettextf(
          "variable %1$s has fewer categories (%2$s) than
          expected (%3$s) in group %4$s", ov.names[i],
          length(y.freq), ov.levels[i], group))
      }
      if (any(y.freq == 0L) & !allow.empty.cell) {
        lav_msg_stop(gettextf(
          "some categories of variable `%1$s' are empty in group %2$s;
          frequencies are [%3$s]", ov.names[i], group,
          lav_msg_view(y.freq, "none")))
      }
      fit <- lav_uvord_fit(y = Y[, i], X = eXo, wt = wt)
      if (any(is.na(fit$theta))) {
        lav_msg_stop(gettextf(
          "probit regression failed for %1$s; X may not be of full rank
          in group %2$s", ov.names[i], group))
      }
      FIT[[i]] <- fit
      TH[[i]] <- fit$theta[fit$th.idx]
      fit.nox <- lav_uvord_th(y = Y[, i], wt = wt)
      TH.NOX[[i]] <- fit.nox
      if (scores.flag) {
        scores <- lav_uvord_scores(y = Y[, i], X = eXo, wt = wt)
      }

      if (allow.empty.cell) {
        if (any(y.freq == 0L)) {
          ## lav_uvord_fit drops thresholds if extreme categories are missing, but not otherwise
          exidx <- rep(TRUE, (ov.levels[i] - 1))
          misidx <- !exidx
          zidx <- y.freq == 0L
          dz <- diff(zidx) == 1L
          if (y.freq[ov.levels[i]] == 0L) {
            wdz <- which(dz)
            nhi <- ov.levels[i] - wdz[length(wdz)]
            exidx[(ov.levels[i] - nhi) : (ov.levels[i] - 1)] <- FALSE
            misidx[(ov.levels[i] - nhi) : (ov.levels[i] - 1)] <- TRUE
          }
          if (any(dz[-length(dz)])) {
            wdz <- which(dz[-length(dz)])
            exidx[wdz + 1] <- FALSE
            misidx[wdz + 1] <- TRUE
          }
          if (y.freq[1] == 0L) {
            nlow <- which( diff(zidx) == -1 )[1]
            exidx[1:nlow] <- FALSE
            misidx[1:nlow] <- TRUE
          }
          TH[[i]] <- TH.NOX[[i]] <- rep(0, ov.levels[i] - 1)
          TH[[i]][exidx] <- fit$theta[fit$th.idx]
          TH.NOX[[i]][exidx] <- fit.nox[exidx]
          for (k in which(misidx)) {
            if (k == 1) {
              TH[[i]][k] <- -4
              TH.NOX[[i]][k] <- -4
            } else if (k == (ov.levels[i] - 1)) {
              TH[[i]][k] <- 4
              TH.NOX[[i]][k] <- 4
            } else {
              TH[[i]][k] <- TH[[i]][(k - 1)] + .01
              TH.NOX[[i]][k] <- TH.NOX[[i]][(k - 1)] + .01
            }
          }
          if (scores.flag) SC.TH[, th.idx[!misidx]] <- scores[, fit$th.idx, drop = FALSE]
        } else if (length(y.freq) != ov.levels[i]) {
          nz <- ov.levels[i] - length(y.freq)
          TH[[i]] <- c(TH[[i]], TH[[i]][length(y.freq)] + (1:nz) * .01)
          if (scores.flag) SC.TH[, th.idx[1:length(y.freq)]] <- scores[, fit$th.idx, drop = FALSE]
        }
        fit$th.idx <- 1:nTH[i]
      } else {
        if (scores.flag) SC.TH[, th.idx] <- scores[, fit$th.idx, drop = FALSE]
      }
      SLOPES[i, ] <- fit$theta[fit$slope.idx]
      if (scores.flag) {
        SC.SL[, sl.idx] <- scores[, fit$slope.idx, drop = FALSE]
      }
      VAR[i] <- 1.0
      TH.NAMES[[i]] <- paste(ov.names[i], "|t", 1:length(TH[[i]]),
        sep = ""
      )
      TH.IDX[[i]] <- rep(i, length(TH[[i]]))
    } else {
      lav_msg_stop(gettext("unknown ov.types:"), ov.types[i])
    }
  }

  list(
    FIT = FIT, VAR = VAR, SLOPES = SLOPES,
    TH = TH, TH.NOX = TH.NOX, TH.IDX = TH.IDX, TH.NAMES = TH.NAMES,
    SC.TH = SC.TH, SC.VAR = SC.VAR, SC.SL = SC.SL,
    th.start.idx = th.start.idx, th.end.idx = th.end.idx
  )
}

# compute logl for the unrestricted (h1) model -- per group
lav_h1_logl <- function(lavdata = NULL,
                        lavsamplestats = NULL,
                        h1.implied = NULL,
                        lavoptions = NULL) {
  # number of groups
  ngroups <- lavdata@ngroups

  logl.group <- rep(as.numeric(NA), ngroups)

  # should compute logl, or return NA?
  logl.ok <- FALSE
  if (lavoptions$estimator %in% c("ML", "MML")) {
    # check if everything is numeric, OR if we have exogenous
    # factor with 2 levels only
    if (all(lavdata@ov$type == "numeric")) {
      logl.ok <- TRUE
    } else {
      not.idx <- which(lavdata@ov$type != "numeric")
      for (i in not.idx) {
        if (lavdata@ov$type[i] == "factor" &&
          lavdata@ov$exo[i] == 1L &&
          lavdata@ov$nlev[i] == 2L) {
          logl.ok <- TRUE
        } else {
          logl.ok <- FALSE
          break
        }
      }
    }
  }

  # lavsamplestats filled in? (not if no data, or samplestats = FALSE)
  if (length(lavsamplestats@ntotal) == 0L ||
      (!is.null(lavoptions$samplestats) && !lavoptions$samplestats)) {
    logl.ok <- FALSE
  }

  # new in 0.6-9 (so SAM can handle N<P)
  if (!is.null(lavoptions$sample.icov) && !lavoptions$sample.icov) {
    logl.ok <- FALSE
  }

  if (logl.ok) {
    for (g in seq_len(ngroups)) {
      if (lavdata@nlevels > 1L) {
        current.verbose <- lav_verbose()
        if (lav_verbose(FALSE))
            on.exit(lav_verbose(current.verbose), TRUE)
        OUT <- lav_mvnorm_cluster_em_sat(
          YLp = lavsamplestats@YLp[[g]],
          Lp = lavdata@Lp[[g]],
          tol = 1e-04, # option?
          min.variance = 1e-05, # option?
          max.iter = 5000L
        ) # option?
        lav_verbose(current.verbose)
        # store logl per group
        logl.group[g] <- OUT$logl
      } else if (lavsamplestats@missing.flag) {
        logl.group[g] <-
          lav_mvnorm_missing_loglik_samplestats(
            Yp     = lavsamplestats@missing[[g]],
            #Mu     = lavsamplestats@missing.h1[[g]]$mu,
            Mu     = h1.implied$mean[[g]],
            #Sigma  = lavsamplestats@missing.h1[[g]]$sigma,
            Sigma  = h1.implied$cov[[g]],
            x.idx  = lavsamplestats@x.idx[[g]],
            x.mean = lavsamplestats@mean.x[[g]],
            x.cov  = lavsamplestats@cov.x[[g]]
          )
      } else { # single-level, complete data
        # all we need is: logdet of covariance matrix, nobs and nvar
        if (lavoptions$conditional.x) {
          logl.group[g] <-
            lav_mvnorm_h1_loglik_samplestats(
              sample.cov.logdet =
                lavsamplestats@res.cov.log.det[[g]],
              sample.nvar =
                NCOL(lavsamplestats@res.cov[[g]]),
              sample.nobs = lavsamplestats@nobs[[g]]
            )
        } else {
          logl.group[g] <-
            lav_mvnorm_h1_loglik_samplestats(
              sample.cov.logdet = lavsamplestats@cov.log.det[[g]],
              sample.nvar       = NCOL(lavsamplestats@cov[[g]]),
              sample.nobs       = lavsamplestats@nobs[[g]],
              x.idx             = lavsamplestats@x.idx[[g]],
              x.cov             = lavsamplestats@cov.x[[g]]
            )
        }
      } # complete
    } # g
  } # logl.ok is TRUE

  out <- list(
    loglik = sum(logl.group),
    loglik.group = logl.group
  )

  out
}

lav_constraints_parse <- function(partable = NULL, constraints = NULL,
                                  theta = NULL,
                                  debug = FALSE) {
  if (!missing(debug)) {
    current.debug <- lav_debug()
    if (lav_debug(debug))
      on.exit(lav_debug(current.debug), TRUE)
  }
  # just in case we do not have a $free column in partable
  if (is.null(partable$free)) {
    partable$free <- seq_len(length(partable$lhs))
  }

  # from the partable: free parameters
  if (!is.null(theta)) {
    # nothing to do
  } else if (!is.null(partable$est)) {
    theta <- partable$est[partable$free > 0L]
  } else if (!is.null(partable$start)) {
    theta <- partable$start[partable$free > 0L]
  } else {
    theta <- rep(0, length(partable$lhs))
  }

  # number of free (but possibliy constrained) parameters
  npar <- length(theta)

  # parse the constraints
  if (is.null(constraints)) {
    LIST <- NULL
  } else if (!is.character(constraints)) {
    lav_msg_stop(gettext("constraints should be a string"))
  } else {
    FLAT <- lavParseModelString(constraints)
    CON <- attr(FLAT, "constraints")
    LIST <- list()
    if (length(CON) > 0L) {
      lhs <- unlist(lapply(CON, "[[", "lhs"))
      op <- unlist(lapply(CON, "[[", "op"))
      rhs <- unlist(lapply(CON, "[[", "rhs"))
      LIST$lhs <- c(LIST$lhs, lhs)
      LIST$op <- c(LIST$op, op)
      LIST$rhs <- c(LIST$rhs, rhs)
    } else {
      lav_msg_stop(gettext("no constraints found in constraints argument"))
    }
  }

  # simple equality constraints?
  ceq.simple <- FALSE
  if (!is.null(partable$unco)) {
    ceq.simple <- TRUE
  }

  # simple inequality constraints?
  cin.simple <- TRUE
  if (any(partable$op %in% c(">", "<"))) {
    cin.simple <- FALSE
  }
  if (!is.null(LIST) && any(LIST$op %in% c(">", "<"))) {
    cin.simple <- FALSE
  }
  if (is.null(partable$upper) && is.null(partable$lower)) {
    cin.simple <- FALSE
  } else {
    # only check free parameters!
    free.idx <- which(partable$free > 0L)
    if (all(partable$lower[free.idx] == -Inf) &&
        all(partable$upper[free.idx] == +Inf)) {
      cin.simple <- FALSE
    }
  }

  # variable definitions
  def.function <- lav_partable_constraints_def(partable,
    con = LIST,
    debug = debug
  )

  # construct ceq/ciq functions
  ceq.function <- lav_partable_constraints_ceq(partable,
    con = LIST,
    debug = debug
  )
  # linear or nonlinear?
  ceq.linear.idx <- lav_constraints_linear_idx(
    func = ceq.function,
    npar = npar
  )
  ceq.nonlinear.idx <- lav_constraints_nonlinear_idx(
    func = ceq.function,
    npar = npar
  )

  # inequalities
  cin.function <- lav_partable_constraints_ciq(partable,
    con = LIST,
    debug = debug
  )

  # linear or nonlinear?
  cin.linear.idx <- lav_constraints_linear_idx(
    func = cin.function,
    npar = npar
  )
  cin.nonlinear.idx <- lav_constraints_nonlinear_idx(
    func = cin.function,
    npar = npar
  )

  # Jacobians
  if (!is.null(body(ceq.function))) {
    ceq.JAC <- try(lav_func_jacobian_complex(
      func = ceq.function,
      x = theta
    ), silent = TRUE)
    if (inherits(ceq.JAC, "try-error")) { # eg. pnorm()
      ceq.JAC <- lav_func_jacobian_simple(func = ceq.function, x = theta)
    }

    # constants
    # do we have a non-zero 'rhs' elements? FIXME!!! is this reliable??
    ceq.rhs <- -1 * ceq.function(numeric(npar))

    # evaluate constraints
    ceq.theta <- ceq.function(theta)
  } else {
    ceq.JAC <- matrix(0, nrow = 0L, ncol = npar)
    ceq.rhs <- numeric(0L)
    ceq.theta <- numeric(0L)
  }

  if (!is.null(body(cin.function))) {
    cin.JAC <- try(lav_func_jacobian_complex(
      func = cin.function,
      x = theta
    ), silent = TRUE)
    if (inherits(cin.JAC, "try-error")) { # eg. pnorm()
      cin.JAC <- lav_func_jacobian_simple(func = cin.function, x = theta)
    }

    # constants
    # do we have a non-zero 'rhs' elements? FIXME!!! is this reliable??
    cin.rhs <- -1 * cin.function(numeric(npar))

    # evaluate constraints
    cin.theta <- cin.function(theta)
  } else {
    cin.JAC <- matrix(0, nrow = 0L, ncol = npar)
    cin.rhs <- numeric(0L)
    cin.theta <- numeric(0L)
  }

  # check for empty/unused constraints (new in 0.6-22)
  if(nrow(ceq.JAC) > 0L) {
    if (all(ceq.JAC == 0)) {
      ceq.JAC <- matrix(0, nrow = 0L, ncol = npar)
      ceq.rhs <- numeric(0L)
      ceq.theta <- numeric(0L)
      ceq.linear.idx <- integer(0L)
      ceq.nonlinear.idx <- integer(0L)
    } else {
      zero.idx <- which(apply(ceq.JAC, 1, function(x) all(x == 0)))
      if (length(zero.idx) > 0L) {
        ceq.JAC <- ceq.JAC[-zero.idx, , drop = FALSE]
        ceq.rhs <- ceq.rhs[-zero.idx]
        ceq.theta <- ceq.theta[-zero.idx]
        # hm, how to hande these? indices no longer match rows of ceq.JAC!
        ceq.linear.idx <- ceq.linear.idx[!ceq.linear.idx %in% zero.idx]
        ceq.nonlinear.idx <- ceq.nonlinear.idx[!ceq.nonlinear.idx %in% zero.idx]
      }
    }
  }
  if(nrow(cin.JAC) > 0L) {
    if (all(cin.JAC == 0)) {
      cin.JAC <- matrix(0, nrow = 0L, ncol = npar)
      cin.rhs <- numeric(0L)
      cin.theta <- numeric(0L)
      cin.linear.idx <- integer(0L)
      cin.nonlinear.idx <- integer(0L)
    } else {
      zero.idx <- which(apply(cin.JAC, 1, function(x) all(x == 0)))
      if (length(zero.idx) > 0L) {
        cin.JAC <- cin.JAC[-zero.idx, , drop = FALSE]
        cin.rhs <- cin.rhs[-zero.idx]
        cin.theta <- cin.theta[-zero.idx]
        # hm, how to hande these? indices no longer match rows of cin.JAC!
        cin.linear.idx <- cin.linear.idx[!cin.linear.idx %in% zero.idx]
        cin.nonlinear.idx <- cin.nonlinear.idx[!cin.nonlinear.idx %in% zero.idx]
      }
    }
  }

  # shortcut flags
  ceq.linear.flag <- length(ceq.linear.idx) > 0L
  ceq.nonlinear.flag <- length(ceq.nonlinear.idx) > 0L
  ceq.flag <- ceq.linear.flag || ceq.nonlinear.flag

  cin.linear.flag <- length(cin.linear.idx) > 0L
  cin.nonlinear.flag <- length(cin.nonlinear.idx) > 0L
  cin.flag <- cin.linear.flag || cin.nonlinear.flag
  if (cin.simple) {
    cin.flag <- FALSE
  }

  ceq.only.flag <- ceq.flag && !cin.flag
  cin.only.flag <- cin.flag && !ceq.flag

  ceq.linear.only.flag <- (ceq.linear.flag &&
    !ceq.nonlinear.flag &&
    !cin.flag && !cin.simple)

  ceq.simple.only <- ceq.simple && !ceq.flag && !cin.flag
  cin.simple.only <- cin.simple && !ceq.linear.flag

  # additional info if ceq.linear.flag
  if (ceq.linear.only.flag) {
    ## NEW: 18 nov 2014: handle general *linear* constraints
    ##
    ## see Nocedal & Wright (2006) 15.3
    ## - from x to x.red:
    ##       x.red <- MASS::ginv(Q2) %*% (x - Q1 %*% solve(t(R)) %*% b)
    ##   or
    ##       x.red <- as.numeric((x - b %*% qr.coef(QR,diag(npar))) %*% Q2)
    ##
    ## - from x.red to x
    ##       x <- as.numeric(Q1 %*% solve(t(R)) %*% b + Q2 %*% x.red)
    ##   or
    ##       x <- as.numeric(b %*% qr.coef(QR, diag(npar))) +
    ##                       as.numeric(Q2 %*% x.red)
    ##
    ## we write eq.constraints.K = Q2
    ##          eq.constraints.k0 = b %*% qr.coef(QR, diag(npar)))

    # compute range+null space of the jacobion (JAC) of the constraint
    # matrix
    # JAC <- lav_func_jacobian_complex(func = ceq.function,
    #           x = lavpartable$start[lavpartable$free > 0L]
    QR <- qr(t(ceq.JAC))
    ranK <- QR$rank
    Q <- qr.Q(QR, complete = TRUE)
    # Q1 <- Q[,1:ranK, drop = FALSE]         # range space
    # Q2 <- Q[,-seq_len(ranK), drop = FALSE] # null space
    # R <- qr.R(QR)
    ceq.JAC.NULL <- Q[, -seq_len(ranK), drop = FALSE]

    if (all(ceq.rhs == 0)) {
      ceq.rhs.NULL <- numeric(npar)
    } else {
      tmp <- qr.coef(QR, diag(npar))
      NA.idx <- which(is.na(rowSums(tmp))) # catch NAs
      if (length(NA.idx) > 0L) {
        tmp[NA.idx, ] <- 0
      }
      ceq.rhs.NULL <- as.numeric(ceq.rhs %*% tmp)
    }
  } else {
    ceq.JAC.NULL <- matrix(0, 0L, 0L)
    ceq.rhs.NULL <- numeric(0L)
  }

  # if simple equalities only, create 'K' matrix
  ceq.simple.K <- matrix(0, 0, 0)
  if (ceq.simple.only) {
    n.unco <- max(partable$unco)
    n.free <- max(partable$free)
    ceq.simple.K <- matrix(0, nrow = n.unco, ncol = n.free)
    #####
    #####     FIXME !
    #####
    idx.free <- partable$free[partable$free > 0]
    for (k in 1:n.unco) {
      c <- idx.free[k]
      ceq.simple.K[k, c] <- 1
    }
  }

  # dummy jacobian 'function'
  ceq.jacobian <- function() NULL
  cin.jacobian <- function() NULL


  OUT <- list(
    def.function = def.function,
    ceq.function = ceq.function,
    ceq.JAC = ceq.JAC,
    ceq.jacobian = ceq.jacobian,
    ceq.rhs = ceq.rhs,
    ceq.theta = ceq.theta,
    ceq.linear.idx = ceq.linear.idx,
    ceq.nonlinear.idx = ceq.nonlinear.idx,
    ceq.linear.flag = ceq.linear.flag,
    ceq.nonlinear.flag = ceq.nonlinear.flag,
    ceq.flag = ceq.flag,
    ceq.linear.only.flag = ceq.linear.only.flag,
    ceq.JAC.NULL = ceq.JAC.NULL,
    ceq.rhs.NULL = ceq.rhs.NULL,
    ceq.simple.only = ceq.simple.only,
    ceq.simple.K = ceq.simple.K,
    cin.function = cin.function,
    cin.JAC = cin.JAC,
    cin.jacobian = cin.jacobian,
    cin.rhs = cin.rhs,
    cin.theta = cin.theta,
    cin.linear.idx = cin.linear.idx,
    cin.nonlinear.idx = cin.nonlinear.idx,
    cin.linear.flag = cin.linear.flag,
    cin.nonlinear.flag = cin.nonlinear.flag,
    cin.flag = cin.flag,
    cin.only.flag = cin.only.flag,
    cin.simple.only = cin.simple.only
  )

  OUT
}

lav_constraints_linear_idx <- function(func = NULL, npar = NULL) {
  if (is.null(func) || is.null(body(func))) {
    return(integer(0L))
  }

  # seed 1: rnorm
  A0 <- lav_func_jacobian_complex(func = func, x = rnorm(npar))

  # seed 2: rnorm
  A1 <- lav_func_jacobian_complex(func = func, x = rnorm(npar))

  A0minA1 <- A0 - A1
  linear <- apply(A0minA1, 1, function(x) all(x == 0))
  which(linear)
}

lav_constraints_nonlinear_idx <- function(func = NULL, npar = NULL) {
  if (is.null(func) || is.null(body(func))) {
    return(integer(0L))
  }

  # seed 1: rnorm
  A0 <- lav_func_jacobian_complex(func = func, x = rnorm(npar))

  # seed 2: rnorm
  A1 <- lav_func_jacobian_complex(func = func, x = rnorm(npar))

  A0minA1 <- A0 - A1
  linear <- apply(A0minA1, 1, function(x) all(x == 0))
  which(!linear)
}


# FIXME: is there a more elegant/robust way to do this??
lav_constraints_check_linear <- function(model) {
  # seed 1: rnorm
  A.ceq <- A.cin <- matrix(0, model@nx.free, 0)
  if (!is.null(body(model@ceq.function))) {
    A.ceq <- t(lav_func_jacobian_complex(func = model@ceq.function, x = rnorm(model@nx.free)))
  }
  if (!is.null(body(model@cin.function))) {
    A.cin <- t(lav_func_jacobian_complex(func = model@cin.function, x = rnorm(model@nx.free)))
  }
  A0 <- cbind(A.ceq, A.cin)

  # seed 2: rnorm
  A.ceq <- A.cin <- matrix(0, model@nx.free, 0)
  if (!is.null(body(model@ceq.function))) {
    A.ceq <- t(lav_func_jacobian_complex(func = model@ceq.function, x = rnorm(model@nx.free)))
  }
  if (!is.null(body(model@cin.function))) {
    A.cin <- t(lav_func_jacobian_complex(func = model@cin.function, x = rnorm(model@nx.free)))
  }
  A1 <- cbind(A.ceq, A.cin)

  A0minA1 <- all.equal(A0, A1)
  if (is.logical(A0minA1) && A0minA1 == TRUE) {
    return(TRUE)
  } else {
    return(FALSE)
  }
}

# check if the equality constraints are 'simple' (a == b)
lav_constraints_check_simple <- function(lavmodel = NULL) {
  ones <- (lavmodel@ceq.JAC == 1 | lavmodel@ceq.JAC == -1)
  simple <- all(lavmodel@ceq.rhs == 0) &&
    all(apply(lavmodel@ceq.JAC != 0, 1, sum) == 2) &&
    all(apply(ones, 1, sum) == 2) &&
    length(lavmodel@ceq.nonlinear.idx) == 0

  # TRUE or FALSE
  simple
}

lav_constraints_R2K <- function(lavmodel = NULL, R = NULL) {
  # constraint matrix
  if (!is.null(lavmodel)) {
    R <- lavmodel@ceq.JAC
  }
  stopifnot(!is.null(R))

  npar.full <- NCOL(R)
  npar.red <- npar.full - NROW(R)

  K <- diag(npar.full)
  for (i in 1:NROW(R)) {
    idx1 <- which(R[i, ] == 1)
    idx2 <- which(R[i, ] == -1)
    K[idx2, idx1] <- 1
  }

  # remove redundant columns
  neg.idx <- which(colSums(R) < 0)
  K <- K[, -neg.idx]

  K
}

lav_constraints_lambda_pre <- function(lavobject = NULL, method = "Don") {
  # compute factor 'pre' so that pre %*% g = lambda
  method <- tolower(method)

  R <- lavobject@Model@con.jac[, ]
  if (is.null(R) || length(R) == 0L) {
    return(numeric(0L))
  }

  INFO <- lavTech(lavobject, "information.first.order")
  npar <- nrow(INFO)

  # Don 1985
  if (method == "don") {
    R.plus <- MASS::ginv(R)

    # construct augmented matrix
    Z <- rbind(
      cbind(INFO, t(R)),
      cbind(R, matrix(0, nrow = nrow(R), ncol = nrow(R)))
    )
    Z.plus <- MASS::ginv(Z)
    P.star <- Z.plus[1:npar, 1:npar]
    PRE <- t(R.plus) %*% (diag(npar) - INFO %*% P.star)

    # Bentler EQS manual
  } else if (method == "bentler") {
    INFO.inv <- solve(INFO)
    PRE <- solve(R %*% INFO.inv %*% t(R)) %*% R %*% INFO.inv
  }

  PRE
}

lav_lavaan_step16_rotation <- function(lavoptions = NULL,
                                       lavmodel = NULL,
                                       lavpartable = NULL,
                                       lavh1 = NULL,
                                       lavdata = NULL,
                                       x = NULL,
                                       lavvcov = NULL,
                                       VCOV = NULL, # nolint
                                       lavcache = NULL,
                                       lavimplied = NULL,
                                       lavsamplestats = NULL) {
  # # # # # # # # # # #
  # #  16. rotation # #
  # # # # # # # # # # #

  # if lavmodel@nefa > 0L and lavoptions$rotation not "none"
  #   store unrotated  solution in partable (column est.unrotated)
  #   rotate lavmodel via lav_model_efa_rotate and overwrite column est
  #     in partable
  #   if lavoptions$se not in none, bootstrap, external, twostep
  #     if lavoptions$rotation.se == "delta"
  #       re-compute vcov with delta rule (*)
  #       re-compute SE and store them in lavpartable (*)
  #     else if lavoptions$rotation.se == "bordered"
  #       create 'new' partable where the user = 7/77 parameters are free (*)
  #
  # (*) code too complicated to summarize here

  if (lavmodel@nefa > 0L &&
    (lavoptions$rotation != "none")) {
    # store unrotated solution in partable
    lavpartable$est.unrotated <- lavpartable$est
    lavpartable$se.unrotated <- lavpartable$se

    # rotate, and create new lavmodel
    if (lav_verbose()) {
      cat(
        "rotating EFA factors using rotation method =",
        toupper(lavoptions$rotation), "..."
      )
    }
    x.unrotated <- as.numeric(x)
    lavmodel.unrot <- lavmodel
    efa.out <- lav_model_efa_rotate(
      lavmodel = lavmodel,
      lavoptions = lavoptions
    )

    # adapt partable:
    # - change 'free' column to reflect that user = 7/77 parameters are free
    # - save unrotated free column in free.unrotated
    lavpartable$free.unrotated <- lavpartable$free
    user7.idx <- which((lavpartable$user == 7L | lavpartable$user == 77L) &
      lavpartable$free == 0L)
    lavpartable$free[user7.idx] <- 1L
    lavpartable$free[lavpartable$free > 0L] <-
      seq_len(sum(lavpartable$free > 0L))
    # avoid cin.simple entries for these user=7 parameters
    if (!is.null(lavpartable$lower)) {
      lavpartable$lower[user7.idx] <- -Inf
    }
    if (!is.null(lavpartable$upper)) {
      lavpartable$upper[user7.idx] <- +Inf
    }

    # create 'rotated' lavmodel, reflecting the 'new' free parameters
    lavmodel <- lav_model(
      lavpartable = lavpartable,
      lavoptions = lavoptions,
      th.idx = lavmodel@th.idx
    )

    # add rotated information
    lavmodel@H <- efa.out$H
    lavmodel@lv.order <- efa.out$lv.order
    lavmodel@GLIST <- efa.out$GLIST

    # add con.jac information (if any)
    lavmodel@con.lambda <- lavmodel.unrot@con.lambda
    if (nrow(lavmodel.unrot@con.jac) > 0L) {
      con.jac <- rbind(lavmodel@ceq.JAC, lavmodel@cin.JAC)
      attr(con.jac, "inactive.idx") <-
        attr(lavmodel.unrot@con.jac, "inactive.idx")
      attr(con.jac, "cin.idx") <- attr(lavmodel.unrot@con.jac, "cin.idx")
      attr(con.jac, "ceq.idx") <- attr(lavmodel.unrot@con.jac, "ceq.idx")
      lavmodel@con.jac <- con.jac
    }

    # overwrite parameters in @ParTable$est
    lavpartable$est <- lav_model_get_parameters(
      lavmodel = lavmodel,
      type = "user", extra = TRUE
    )
    if (lav_verbose()) {
      cat(" done.\n")
    }

    # VCOV rotated parameters
    if (!lavoptions$se %in% c("none", "bootstrap", "external", "two.step")) {
      if (lav_verbose()) {
        cat(
          "computing VCOV for se =", lavoptions$se,
          "and rotation.se =", lavoptions$rotation.se, "..."
        )
      }

      # use delta rule to recompute vcov
      if (lavoptions$rotation.se == "delta") {
        # Jacobian
        JAC <- numDeriv::jacobian( # nolint
          func = lav_model_efa_rotate_x,
          x = x.unrotated, lavmodel = lavmodel.unrot,
          init.rot = lavmodel@H, lavoptions = lavoptions,
          type = "user", extra = FALSE,
          method.args = list(eps = 0.0050),
          method = "simple"
        ) # important!

        # force VCOV to be pd, before we transform (not very elegant)
        VCOV.in <- lav_matrix_symmetric_force_pd(lavvcov$vcov, # nolint
          tol = 1e-10
        )
        # apply Delta rule
        VCOV.user <- JAC %*% VCOV.in %*% t(JAC) # nolint

        # re-compute SE and store them in lavpartable
        tmp <- diag(VCOV.user)
        min.idx <- which(tmp < 0)
        if (length(min.idx) > 0L) {
          tmp[min.idx] <- as.numeric(NA)
        }
        tmp <- sqrt(tmp)
        # catch near-zero SEs  (was ^(1/2) < 0.6)
        zero.idx <- which(tmp < .Machine$double.eps^(1 / 3))
        if (length(zero.idx) > 0L) {
          tmp[zero.idx] <- 0.0
        }
        lavpartable$se <- tmp

        # store rotated VCOV
        # lavvcov$vcov.unrotated <- lavvcov$vcov
        if (lavmodel@ceq.simple.only) {
          free.idx <- which(lavpartable$free > 0L &&
            !duplicated(lavpartable$free))
        } else {
          free.idx <- which(lavpartable$free > 0L)
        }
        lavvcov$vcov <- VCOV.user[free.idx, free.idx, drop = FALSE]

        # rotation.se = "bordered" is the default
      } else if (lavoptions$rotation.se == "bordered") {
        # create 'border' for augmented information matrix
        x.rot <- lav_model_get_parameters(lavmodel)
        JAC <- numDeriv::jacobian( # nolint
          func = lav_model_efa_rotate_border_x,
          x = x.rot, lavmodel = lavmodel,
          lavoptions = lavoptions,
          lavpartable = lavpartable,
          # method.args = list(eps = 0.0005),
          # method = "simple")
          method = "Richardson"
        )
        # store JAC
        lavmodel@ceq.efa.JAC <- JAC

        # no other constraints
        if (nrow(lavmodel@con.jac) == 0L) {
          lavmodel@con.jac <- JAC
          attr(lavmodel@con.jac, "inactive.idx") <- integer(0L)
          attr(lavmodel@con.jac, "ceq.idx") <- seq_len(nrow(JAC))
          attr(lavmodel@con.jac, "cin.idx") <- integer(0L)
          lavmodel@con.lambda <- rep(0, nrow(JAC))

          # other constraints
        } else {
          inactive.idx <- attr(lavmodel@con.jac, "inactive.idx")
          ceq.idx <- attr(lavmodel@con.jac, "ceq.idx")
          cin.idx <- attr(lavmodel@con.jac, "cin.idx")
          lambda <- lavmodel@con.lambda
          nbord <- nrow(JAC)

          # reconstruct con.jac
          CON.JAC <- rbind(JAC, lavmodel@ceq.JAC, lavmodel@cin.JAC) # nolint
          attr(CON.JAC, "cin.idx") <- cin.idx + nbord # nolint
          attr(CON.JAC, "ceq.idx") <- c(1:nbord, ceq.idx + nbord) # nolint
          attr(CON.JAC, "inactive.idx") <- inactive.idx + nbord # nolint

          lavmodel@con.jac <- CON.JAC
          lavmodel@con.lambda <- c(rep(0, nbord), lambda)
        }

        # compute VCOV, taking 'rotation constraints' into account
        VCOV <- lav_model_vcov( # nolint
          lavmodel = lavmodel,
          lavsamplestats = lavsamplestats,
          lavoptions = lavoptions,
          lavdata = lavdata,
          lavpartable = lavpartable,
          lavcache = lavcache,
          lavimplied = lavimplied,
          lavh1 = lavh1
        )

        # compute SE and store them in lavpartable
        tmp <- lav_model_vcov_se(
          lavmodel = lavmodel,
          lavpartable = lavpartable, VCOV = VCOV
        )
        lavpartable$se <- tmp

        # store rotated VCOV in lavvcov
        tmp.attr <- attributes(VCOV)
        VCOV1 <- VCOV # nolint
        attributes(VCOV1) <- tmp.attr["dim"] # nolint
        # lavvcov$vcov.unrotated <- lavvcov$vcov
        lavvcov$vcov <- VCOV1
      } # bordered

      if (lav_verbose()) {
        cat(" done.\n")
      }
    } # vcov
  } # efa

  list(
    lavpartable = lavpartable,
    lavmodel    = lavmodel,
    lavvcov     = lavvcov
  )
}

# export go BUGS syntax

# we assume that N1, N2, ... are in data
lav_export_bugs <- function(partable, as.function. = FALSE) {
  # get parameter table attributes
  pta <- lav_partable_attributes(partable = partable)
  vnames <- pta$vnames
  nblocks <- pta$nblocks
  nvar <- pta$nvar
  nfac <- pta$nfac

  # sanity check
  partable <- lav_export_check(partable)

  # tabs
  t1 <- paste(rep(" ", 2L), collapse = "")
  t2 <- paste(rep(" ", 4L), collapse = "")
  t3 <- paste(rep(" ", 6L), collapse = "")
  t4 <- paste(rep(" ", 8L), collapse = "")

  # TXT header
  if (as.function.) {
    TXT <- paste("{\n", sep = "")
  } else {
    TXT <- paste("model {\n", sep = "")
  }

  # model for every i
  for (g in 1:nblocks) {
    ov.names <- vnames$ov[[g]]
    lv.names <- vnames$lv[[g]]
    yname <- paste("y", g, sep = "")
    if (nblocks > 1L) {
      TXT <- paste(TXT, t1,
        "# block ", g, "\n",
        sep = ""
      )
    } else {
      TXT <- paste(TXT, "\n")
    }
    TXT <- paste(TXT, t1,
      "for(i in 1:N", g, ") {\n",
      sep = ""
    )

    # ov.nox - all observed variables (except exogenous ones)
    ov.names.nox <- vnames$ov.nox[[g]]
    nov <- length(ov.names.nox)
    TXT <- paste(TXT, "\n", t2,
      "# ov.nox",
      sep = ""
    )
    for (i in 1:nov) {
      ov.idx <- match(ov.names.nox[i], ov.names)
      theta.free.idx <- which(partable$block == g &
        partable$op == "~~" &
        partable$lhs == partable$rhs &
        partable$lhs == ov.names.nox[i])
      if (length(theta.free.idx) != 1L) {
        lav_msg_stop(gettextf(
          "parameter for residual variance %s not found",
          ov.names.nox[i])
        )
      } else {
        theta.idx <- partable$free[theta.free.idx]
      }
      TXT <- paste(TXT, "\n", t2,
        yname, "[i,", ov.idx, "] ~ dnorm(mu", g, "[i,", ov.idx,
        "], itheta[", theta.idx, "])",
        sep = ""
      )
    }

    TXT <- paste(TXT, "\n", t2, sep = "")
    for (i in 1:nov) {
      ov.idx <- match(ov.names.nox[i], ov.names)
      TXT <- paste(TXT, "\n", t2,
        "mu", g, "[i,", ov.idx, "] <- ",
        sep = ""
      )

      # find rhs for this observed variable

      # 1. intercept?
      int.idx <- which(partable$block == g &
        partable$op == "~1" &
        partable$lhs == ov.names.nox[i])
      if (length(int.idx) == 1L) {
        # fixed or free?
        if (partable$free[int.idx] == 0L) {
          TXT <- paste(TXT,
            partable$ustart[int.idx],
            sep = ""
          )
        } else {
          TXT <- paste(TXT,
            "theta[", partable$free[int.idx], "]",
            sep = ""
          )
        }
      } else { # no intercept, say '0', so we always have rhs
        TXT <- paste(TXT, "0", sep = "")
      }

      # 2. factor loading?
      lam.idx <- which(partable$block == g &
        partable$op == "=~" &
        partable$rhs == ov.names.nox[i])
      for (j in lam.idx) {
        # fixed or free?
        if (partable$free[j] == 0L) {
          TXT <- paste(TXT, " + ",
            partable$ustart[j], "*eta", g, "[i,",
            match(partable$lhs[j], lv.names),
            "]",
            sep = ""
          )
        } else {
          TXT <- paste(TXT, " + ",
            "theta[", partable$free[j], "]*eta", g, "[i,",
            match(partable$lhs[j], lv.names),
            "]",
            sep = ""
          )
        }
      }

      # 3. regression?
      r.idx <- which(partable$block == g &
        partable$op == "~" &
        partable$lhs == ov.names.nox[i])
      for (j in r.idx) {
        # what is the rhs?
        rhs <- partable$rhs[j]
        if (rhs %in% lv.names) {
          RHS <- paste("eta", g, "[i,",
            match(rhs, lv.names), "]",
            sep = ""
          )
        } else if (rhs %in% vnames$ov[[g]]) {
          RHS <- paste("y", g, "[i,",
            match(rhs, ov.names), "]",
            sep = ""
          )
        }

        # fixed or free?
        if (partable$free[j] == 0L) {
          TXT <- paste(TXT, " + ",
            partable$ustart[j], "*", RHS,
            sep = ""
          )
        } else {
          TXT <- paste(TXT, " + ",
            "theta[", partable$free[j], "]*", RHS,
            sep = ""
          )
        }
      }
    }


    # lv.y
    # var(lv.y) = PSI (lisrel style)
    lv.y <- vnames$lv.y[[g]]
    if (length(lv.y) > 0L) {
      TXT <- paste(TXT, "\n\n", t2,
        "# lv.y",
        sep = ""
      )
      lv.y.idx <- match(lv.y, lv.names)
      ny <- length(lv.y.idx)
      for (j in 1:ny) {
        theta.free.idx <- which(partable$block == g &
          partable$op == "~~" &
          partable$lhs == partable$rhs &
          partable$lhs == lv.y[j])
        if (length(theta.free.idx) != 1L) {
          lav_msg_stop(gettextf(
            "parameter for residual variance %s not found",
            lv.y[j])
          )
        } else {
          theta.idx <- partable$free[theta.free.idx]
        }
        TXT <- paste(TXT, "\n", t2,
          # dnorm for now
          "eta", g, "[i,", lv.y.idx[j], "] ~ dnorm(mu.eta", g, "[i,",
          lv.y.idx[j], "], itheta[", theta.idx, "])",
          sep = ""
        )
      }
      for (j in 1:ny) {
        TXT <- paste(TXT, "\n", t2,
          # dnorm for now
          "mu.eta", g, "[i,", lv.y.idx[j], "] <- ",
          sep = ""
        )

        # lhs elements regression
        # 1. intercept?
        int.idx <- which(partable$block == g &
          partable$op == "~1" &
          partable$lhs == lv.y[j])
        if (length(int.idx) == 1L) {
          # fixed or free?
          if (partable$free[int.idx] == 0L) {
            TXT <- paste(TXT,
              partable$ustart[int.idx],
              sep = ""
            )
          } else {
            TXT <- paste(TXT,
              "theta[", partable$free[int.idx], "]",
              sep = ""
            )
          }
        } else { # no intercept, say '0', so we always have rhs
          TXT <- paste(TXT, "0", sep = "")
        }

        rhs.idx <- which(partable$block == g &
          partable$op == "~" &
          partable$lhs == lv.y[j])
        np <- length(rhs.idx)
        for (p in 1:np) {
          TXT <- paste(TXT, " + ",
            "theta[", partable$free[rhs.idx[p]],
            "]*eta", g, "[i,",
            match(partable$rhs[rhs.idx[p]], lv.names),
            "]",
            sep = ""
          )
        }
      }
    }

    # exogenous lv -- FIXME: we assume the lv.x array is continous
    # (eg 3,4,5, but NOT 3,5,6)
    # var(lv.x) = PHI (lisrel style)
    lv.x <- vnames$lv.x[[g]]
    if (length(lv.x) > 0L) {
      TXT <- paste(TXT, "\n\n", t2,
        "# lv.x",
        sep = ""
      )
      lv.x.idx <- match(lv.x, lv.names)
      nx <- length(lv.x.idx)
      TXT <- paste(TXT, "\n", t2,
        # dmnorm for now
        "eta", g, "[i,", min(lv.x.idx), ":", max(lv.x.idx),
        "] ~ dmnorm(mu.eta", g, "[i,", min(lv.x.idx), ":",
        max(lv.x.idx), "], iphi", g, "[1:", nx, ",1:", nx, "])",
        sep = ""
      )
      for (j in 1:nx) {
        TXT <- paste(TXT, "\n", t2,
          "mu.eta", g, "[i,", lv.x.idx[j], "] <- 0",
          sep = ""
        )
      }
    }


    # exogenous ov ??? (what to do here?)

    # end of this block
    TXT <- paste(TXT, "\n\n", t1,
      "} # end of block ", g, "\n",
      sep = ""
    )
  }

  # priors (both fixed and free)
  TXT <- paste(TXT, "\n", t1,
    "# Priors free parameters (univariate):",
    sep = ""
  )
  npt <- length(partable$lhs)
  for (i in seq_len(npt)) {
    if (partable$free[i] == 0L) next # skip non-free parameters
    lhs <- partable$lhs[i]
    op <- partable$op[i]
    rhs <- partable$rhs[i]
    free.idx <- partable$free[i]
    g <- partable$block[i]
    if (op == "=~") {
      # factor loading
      TXT <- paste(TXT, "\n", t1,
        "theta[", free.idx, "] ~ dnorm(0.8, 1)",
        sep = ""
      )
    } else if (op == "~") {
      # regression
      TXT <- paste(TXT, "\n", t1,
        "theta[", free.idx, "] ~ dnorm(0, 1)",
        sep = ""
      )
    } else if (op == "~~" && lhs == rhs) {
      # variance
      # 1. lv.x + lv.x (skip -> multivariate)
      # 2. lv.y + lv.y
      # 3. observed + observed
      # 4. else -> fix (upgrade to latent?)
      if (lhs %in% vnames$lv.x[[g]] && rhs %in% vnames$lv.x[[g]]) {
        # lv.x: move to multivariate... (dwish)
        next
      } else if (lhs %in% vnames$lv.y[[g]] && rhs %in% vnames$lv.y[[g]]) {
        # lv.y
        TXT <- paste(TXT, "\n", t1,
          "itheta[", free.idx, "] ~ dgamma(9, 4)",
          sep = ""
        )
        TXT <- paste(TXT, "\n", t1,
          "theta[", free.idx, "] <- 1/itheta[", free.idx, "]",
          sep = ""
        )
      } else if (lhs %in% vnames$ov[[g]] && rhs %in% vnames$ov[[g]]) {
        TXT <- paste(TXT, "\n", t1,
          "itheta[", free.idx, "] ~ dgamma(9, 4)",
          sep = ""
        )
        TXT <- paste(TXT, "\n", t1,
          "theta[", free.idx, "] <- 1/itheta[", free.idx, "]",
          sep = ""
        )
      } else {
        lav_msg_stop(gettextf("FIXME!! parameter %s", i))
      }
    } else if (op == "~~" && lhs != rhs) {
      # covariance
      # 1. lv.x + lv.x (skip -> multivariate)
      # 2. lv.y + lv.y
      # 3. observed + observed
      # 4. else -> fix (upgrade to latent?)
      if (lhs %in% vnames$lv.x[[g]] && rhs %in% vnames$lv.x[[g]]) {
        # exo lv covariance
        next
      } else if (lhs %in% vnames$lv.y[[g]] && rhs %in% vnames$lv.y[[g]]) {
        # lv.y
        lav_msg_stop(gettextf("FIXME!! parameter ", i))
      } else if (lhs %in% vnames$ov[[g]] && rhs %in% vnames$ov[[g]]) {
        TXT <- paste(TXT, "\n", t1,
          "itheta[", free.idx, "] ~ dgamma(9, 4)",
          sep = ""
        )
        TXT <- paste(TXT, "\n", t1,
          "theta[", free.idx, "] <- 1/itheta[", free.idx, "]",
          sep = ""
        )
      } else {
        lav_msg_stop(gettextf("FIXME!! parameter ", i))
      }
    } else if (op == "~1") {
      # intercept
      TXT <- paste(TXT, "\n", t1,
        "theta[", free.idx, "] ~ dnorm(0, 1)",
        sep = ""
      )
    } else {
      lav_msg_stop(gettextf("op not supported yet for parameter ", i))
    }
  }

  TXT <- paste(TXT, "\n\n", t1,
    "# Priors free parameters (multivariate):",
    sep = ""
  )
  for (g in 1:nblocks) {
    lv.phi.idx <- which(partable$block == g &
      partable$op == "~~" &
      partable$lhs %in% vnames$lv.x[[g]] &
      partable$rhs %in% vnames$lv.x[[g]])
    nx <- length(vnames$lv.x[[g]])
    if (length(nx) > 0L) {
      TXT <- paste(TXT, "\n", t1,
        "iphi", g, "[1:", nx, ",1:", nx, "] ~ dwish(R", g, "[1:",
        nx, ",1:", nx, "], 5)",
        sep = ""
      )
      TXT <- paste(TXT, "\n", t1,
        "phi", g, "[1:", nx, ",1:", nx, "] <- inverse(iphi", g, "[1:",
        nx, ",1:", nx, "])",
        sep = ""
      )
      for (idx in lv.phi.idx) {
        TXT <- paste(TXT, "\n", t1,
          "theta[", partable$free[idx], "] <- phi", g, "[",
          match(partable$lhs[idx], vnames$lv.x[[g]]), ",",
          match(partable$rhs[idx], vnames$lv.x[[g]]), "]",
          sep = ""
        )
      }
    }
  }

  # end of model
  TXT <- paste(TXT, "\n\n", "} # End of model\n", sep = "")

  # end of model
  if (as.function.) {
    out <- function() NULL
    formals(out) <- alist()
    body(out) <- parse(file = "", text = TXT)
  } else {
    out <- TXT
    class(out) <- c("lavaan.character", "character")
  }

  out
}

# small utility functions to deal with PRELIS
# Y.R.: 11 dec 2012
prelis.read.cor <- function(file = "") {
  # read in numbers as characters
  txt <- scan(file, what = "character", quiet = TRUE)

  # convert to numbers
  txt <- gsub("D", "e", txt)
  x <- as.numeric(txt)

  # create COR/COR matrix
  COR <- lav_matrix_lower2full(x, diagonal = TRUE)
  COR
}


prelis.read.acm <- function(file = "", rescale = 1e-3) {
  # read in raw data -- ignore first three elements
  # first element: 123.456789 (check?)
  # second element: 2.72 version number of prelis
  # third element: almost zero??
  zz <- file(file, "rb")
  raw <- readBin(zz, what = "double", n = 1e+05)[-c(1, 2, 3)]
  close(zz)

  # scale numbers
  raw <- raw * rescale

  ACM <- lav_matrix_lower2full(raw, diagonal = TRUE)

  # elements are divided by 2??
  ACM <- ACM * 2
  ACM
}

prelis.write.data <- function(data, file = "prelis", na.rm = TRUE,
                              labels = FALSE, std.ov = FALSE) {
  dfile <- paste(file, ".raw", sep = "")
  write.table(data,
    file = dfile, na = "-999999", col.names = FALSE,
    row.names = FALSE, quote = FALSE
  )
  if (labels) {
    lfile <- paste(file, ".lab", sep = "")
    write.table(unique(names(data)),
      file = lfile, row.names = F,
      col.names = F, quote = F
    )
  }
}

prelis.run <- function(X, type = "OR", keep.files = FALSE) {
  label <- names(X)
  nvar <- ncol(X)

  # write raw data
  prelis.write.data(X, file = "prelistmp")

  # write syntax
  txt <- paste("DA NI=", nvar, " NO=0 MI=-999999\n", sep = "")
  txt <- paste(txt, "LA", sep = "")
  tmp <- 0
  for (i in 1:nvar) {
    if (tmp %% 6 == 0) txt <- paste(txt, "\n", sep = "")
    txt <- paste(txt, label[i], " ", sep = "")
    tmp <- tmp + 1
  }
  txt <- paste(txt, "\n")
  txt <- paste(txt, "RA FI=prelistmp.raw\n", sep = "")
  txt <- paste(txt, type, " ALL\n", sep = "")
  txt <- paste(txt, "OU MA=PM SA=prelistmp.acm SM=prelistmp.cor\n", sep = "")
  writeLines(txt, con = "prelistmp.in")

  # run prelis
  system("prelis prelistmp.in prelistmp.out")

  # read in acm and cor
  ACM <- prelis.read.acm(file = "prelistmp.acm")
  COR <- prelis.read.cor(file = "prelistmp.cor")

  # clean up
  if (!keep.files) {
    unlink(c(
      "prelistmp.in", "prelistmp.out", "prelistmp.acm",
      "prelistmp.cor", "prelistmp.FREQ", "prelistmp.raw"
    ))
  }

  list(COR = COR, ACM = ACM)
}

# handle ov.order = "data" by adding attribute "ovda" to FLAT
lav_partable_ov_from_data <- function(FLAT = NULL, # nolint
                                      data = NULL,
                                      sample.cov = NULL,
                                      slotData = NULL) { # nolint
  # current model-based ov.names
  ov.names <- lav_partable_vnames(FLAT, type = "ov")

  # get data-based ov.names
  data.names <- NULL
  if (!is.null(data)) {
    data.names <- names(data)
  } else if (!is.null(sample.cov)) {
    # multiple group/blocks?
    if (is.list(sample.cov)) {
      data.names <- unique(unlist(lapply(sample.cov, colnames)))
      if (is.null(data.names)) {
        # try again with rows
        data.names <- unique(unlist(lapply(sample.cov, rownames)))
      }
    } else {
      data.names <- colnames(sample.cov)
      if (is.null(data.names)) {
        # try again with rows
        data.names <- rownames(sample.cov)
      }
    }
  } else if (!is.null(slotData)) {
    data.names <- unique(unlist(slotData@ov.names))
  }

  if (is.null(data.names) || length(data.names) == 0L) {
    lav_msg_stop(gettext("could not find variable names in data/sample.cov"))
  }

  # extract needed ov.names in the same order as the data
  ov.names.data <- data.names[data.names %in% ov.names]

  # check if we have all of them
  if (length(ov.names.data) != length(ov.names)) {
    idx.missing <- which(!(ov.names %in% ov.names.data))
    lav_msg_stop(gettextf(
      "some (observed) variables specified in the model are not found
      in the data: %s",
      lav_msg_view(ov.names[idx.missing], "none")))
  }

  # check if the order is the same
  if (!identical(ov.names, ov.names.data)) {
    attr(FLAT, "ovda") <- ov.names.data # nolint
  }
  return(FLAT)
}

# utility function related to EFA

# generate 'efa' syntax for a single block of factors
lav_syntax_efa <- function(ov.names = NULL, nfactors = 1L, twolevel = FALSE) {
  if (twolevel) {
    tmp <- lav_syntax_efa(ov.names = ov.names, nfactors = nfactors)
    model <- c("level: 1", tmp, "level: 2", tmp)
  } else {
    model <- character(nfactors)
    for (f in seq_len(nfactors)) {
      txt <- paste('efa("efa")*f', f, " =~ ",
        paste(ov.names, collapse = " + "),
        sep = ""
      )
      model[f] <- txt
    }
  }

  model
}

# extract *standardized* loadings from efaList
lav_efa_get_loadings <- function(object, ...) {
  # kill object$loadings if present
  object[["loadings"]] <- NULL

  out <- lapply(object, function(x) {
    STD <- lavTech(x, "std",
      add.class = TRUE, add.labels = TRUE,
      list.by.group = FALSE
    )
    lambda.idx <- which(names(STD) == "lambda")
    LAMBDA <- STD[lambda.idx]
    names(LAMBDA) <- NULL
    # if only single block, drop list
    if (length(LAMBDA) == 1L) {
      LAMBDA <- LAMBDA[[1]]
    } else {
      names(LAMBDA) <- x@Data@block.label
    }
    LAMBDA
  })

  # drop list if only a single model
  if (length(out) == 1L) {
    out <- out[[1]]
  }

  out
}

# find the best ordering of the columns in lambda_target, to minimize
# the difference with the reference lambda matrix (lambda_ref)
#
# return the optimal order of the column for lambda_target
lav_efa_find_best_order <- function(lambda_ref = NULL, lambda_target = NULL,
                                    crit = "rmse") {
  M <- ncol(lambda_ref)
  stopifnot(ncol(lambda_target) == M)

  # all possible permutation
  # FIXEM:we really need a more elegant way to find the permutations...
  tmp <- unname(as.matrix(expand.grid(rep(list(seq_len(M)), M))))
  # select only rows where all numbers appear
  perm <- tmp[apply(tmp, 1L, function(x) { length(unique(x)) == M }), ,
              drop = FALSE]

  rmse.perm <- numeric( nrow(perm) )
  for (p in seq_len(nrow(perm))) {
    diff <- lambda_ref - lambda_target[,perm[p,], drop = FALSE]
    diff2 <- diff * diff
    mse <- mean(diff2)
    rmse.perm[p] <- sqrt(mse)
  }
  best.idx <- which.min(rmse.perm)

  # return 'best' permutation
  perm[best.idx,]
}

lav_lavaan_step12_implied <- function(lavoptions = NULL,
                                      lavmodel = NULL) {
  # # # # # # # # # # # #
  # #  12. lavimplied # #
  # # # # # # # # # # # #

  # if lavoptions$implied compute lavimplied via lav_model_implied
  lavimplied <- list()
  if (lavoptions$implied) {
    if (lav_verbose()) {
      cat("lavimplied  ...")
    }
    lavimplied <- lav_model_implied(lavmodel)
    if (lav_verbose()) {
      cat(" done.\n")
    }
  }

  lavimplied
}

lav_lavaan_step12_loglik <- function(lavoptions = NULL,
                                     lavdata = NULL,
                                     lavsamplestats = NULL,
                                     lavh1 = NULL,
                                     lavimplied = NULL,
                                     lavmodel = NULL) {
  # # # # # # # # # # # #
  # #  12. lavloglik  # #
  # # # # # # # # # # # #

  # only when missing = "ml" and zero coverage
  if (lavoptions$missing == "ml" && lavoptions$model.type == "unrestricted" &&
      length(lavh1) == 0L) {
    lavh1 <- list(implied = lavimplied,
                  logl = list())
  }

  # if lavoptions$loglik compute lavloglik via lav_model_loglik
  lavloglik <- list()
  if (lavoptions$loglik) {
    if (lav_verbose()) {
      cat("lavloglik   ...")
    }
    lavloglik <- lav_model_loglik(
      lavdata = lavdata,
      lavsamplestats = lavsamplestats,
      lavh1 = lavh1,
      lavimplied = lavimplied,
      lavmodel = lavmodel,
      lavoptions = lavoptions
    )
    if (lav_verbose()) {
      cat(" done.\n")
    }
  }

  lavloglik
}

lav_lavaan_step14_test <- function(lavoptions = NULL,
                                   lavmodel = NULL,
                                   lavsamplestats = NULL,
                                   lavdata = NULL,
                                   lavpartable = NULL,
                                   lavcache = NULL,
                                   lavimplied = NULL,
                                   lavh1 = NULL,
                                   x = NULL,
                                   VCOV = NULL, # nolint
                                   lavloglik = NULL) {
  # # # # # # # # # # #
  # #  14. lavtest # #
  # # # # # # # # # # #

  # if lavoptions$test != "none" and x converged
  #   compute lavtest via lav_model_test(...)
  # else
  #   lavtest <- list(list(test = "none", stat = NA,
  #                        stat.group = rep(NA, lavdata@ngroups),
  #                        df = NA, refdistr = "unknown", pvalue = NA))
  lavtest <- NULL
  if (!(length(lavoptions$test) == 1L && lavoptions$test == "none") &&
    attr(x, "converged")) {
    if (lav_verbose()) {
      cat("computing TEST for test(s) =", lavoptions$test, "...")
    }
    lavtest <- lav_model_test(
      lavmodel = lavmodel,
      lavpartable = lavpartable,
      lavsamplestats = lavsamplestats,
      lavimplied = lavimplied,
      lavh1 = lavh1,
      lavoptions = lavoptions,
      x = x,
      VCOV = VCOV,
      lavdata = lavdata,
      lavcache = lavcache,
      lavloglik = lavloglik
    )
    if (lav_verbose()) {
      cat(" done.\n")
    }
  } else {
    lavtest <- list(list(
      test = "none", stat = NA,
      stat.group = rep(NA, lavdata@ngroups), df = NA,
      refdistr = "unknown", pvalue = NA
    ))
  }

  lavtest
}

lav_lavaan_step14_fit <- function(lavpartable = NULL,
                                  lavmodel = NULL,
                                  lavimplied = NULL,
                                  x = NULL,
                                  VCOV = NULL, # nolint
                                  lavtest = NULL) {
  # # # # # # # # # # # #
  # #  14bis. lavfit  # # -> remove if the offending packages are fixed!!
  # # # # # # # # # # # #

  lavfit <- lav_model_fit(
    lavpartable = lavpartable,
    lavmodel = lavmodel,
    lavimplied = lavimplied,
    x = x,
    VCOV = VCOV,
    TEST = lavtest
  )
  # lavfit <- new("Fit")

  lavfit
}

# compute WLS.est (as a list per group)
lav_model_wls_est <- function(lavmodel = NULL, GLIST = NULL,
                              lavimplied = NULL) {
  nblocks <- lavmodel@nblocks
  meanstructure <- lavmodel@meanstructure
  correlation <- lavmodel@correlation
  categorical <- lavmodel@categorical
  group.w.free <- lavmodel@group.w.free
  num.idx <- lavmodel@num.idx

  # model-implied statistics
  if (is.null(lavimplied)) {
    lavimplied <- lav_model_implied(lavmodel, GLIST = GLIST)
  }

  WLS.est <- vector("list", length = nblocks)
  for (g in 1:nblocks) {
    if (categorical) {
      # order of elements is important here:
      # 1. thresholds + means (interleaved)
      # 2. slopes (if any, columnwise per exo)
      # 3. variances (if any)
      # 4. correlations (no diagonal!)
      if (lavmodel@conditional.x) {
        wls.est <- c(
          lavimplied$res.th[[g]],
          lav_matrix_vec(lavimplied$res.slopes[[g]]),
          diag(lavimplied$res.cov[[g]])[num.idx[[g]]],
          lav_matrix_vech(lavimplied$res.cov[[g]],
            diagonal = FALSE
          )
        )
      } else {
        wls.est <- c(
          lavimplied$th[[g]],
          diag(lavimplied$cov[[g]])[num.idx[[g]]],
          lav_matrix_vech(lavimplied$cov[[g]],
            diagonal = FALSE
          )
        )
      }
    } else {
      # CONTINUOUS
      DIAG <- TRUE
      if (correlation) {
        DIAG <- FALSE
      }

      if (lavmodel@conditional.x && lavmodel@nexo[g] > 0L) {
        # order = vec(Beta), where first row are intercepts
        # cbind(res.int, res.slopes) is t(Beta)
        # so we need vecr
        if (meanstructure) {
          wls.est <- c(
            lav_matrix_vecr(
              cbind(
                lavimplied$res.int[[g]],
                lavimplied$res.slopes[[g]]
              )
            ),
            lav_matrix_vech(lavimplied$res.cov[[g]],
              diagonal = DIAG
            )
          )
        } else {
          wls.est <- c(
            lav_matrix_vecr(lavimplied$res.slopes[[g]]),
            lav_matrix_vech(lavimplied$res.cov[[g]],
              diagonal = DIAG
            )
          )
        }
      } else {
        if (meanstructure) {
          wls.est <- c(
            lavimplied$mean[[g]],
            lav_matrix_vech(lavimplied$cov[[g]],
              diagonal = DIAG
            )
          )
        } else {
          wls.est <- lav_matrix_vech(lavimplied$cov[[g]],
            diagonal = DIAG
          )
        }
      } # conditional.x = FALSE
    } # categorical = FALSE

    if (group.w.free) {
      wls.est <- c(lavimplied$group.w[[g]], wls.est)
    }

    WLS.est[[g]] <- wls.est
  }

  WLS.est
}

# Note: lav_model_wls_v() is replaced by lav_model_h1_information() in 0.6-1

lav_lavaan_step05_samplestats <- function(slotSampleStats = NULL, # nolint
                                          lavdata = NULL,
                                          lavoptions = NULL,
                                          WLS.V = NULL, # nolint
                                          NACOV = NULL, # nolint
                                          sample.cov = NULL,
                                          sample.mean = NULL,
                                          sample.th = NULL,
                                          sample.nobs = NULL,
                                          ov.names = NULL,
                                          ov.names.x = NULL,
                                          lavpartable = NULL) {
  # # # # # # # # # # # # # #
  # #  5. lavsamplestats  # #
  # # # # # # # # # # # # # #

  # if slotSampleStats not NULL
  #   copy to lavsamplestats
  # else
  #   if lavdata@data.type == "full"
  #     compute lavsamplestats via lav_samplestats_from_data
  #   else
  #     if lavdata@data.type == "moment"
  #       if lavoptions$meanstructure TRUE but sample.mean is NULL:
  #         ** warning **
  #       compute lavsamplestats via lav_samplestats_from_moments
  #     else
  #       create lavsamplestats object (type lavSampleStats) with data from
  #         lavdata and lavpta

  if (!is.null(slotSampleStats)) {
    lavsamplestats <- slotSampleStats
  } else if (lavdata@data.type == "full") {
    if (lav_verbose()) {
      cat("lavsamplestats     ...")
    }
    lavsamplestats <- lav_samplestats_from_data(
      lavdata       = lavdata,
      lavoptions    = lavoptions,
      WLS.V         = WLS.V,
      NACOV         = NACOV
    )
    if (lav_verbose()) {
      cat(" done.\n")
    }
  } else if (lavdata@data.type == "moment") {
    if (lav_verbose()) {
      cat("lavsamplestats ...")
    }
    # check if we have sample.mean and meanstructure = TRUE
    if (lavoptions$meanstructure && is.null(sample.mean)) {
      lav_msg_warn(
        gettext("sample.mean= argument is missing, but model contains
                mean/intercept parameters."))
    }
    lavsamplestats <- lav_samplestats_from_moments(
      sample.cov    = sample.cov,
      sample.mean   = sample.mean,
      sample.th     = sample.th,
      sample.nobs   = sample.nobs,
      ov.names      = ov.names,
      ov.names.x    = ov.names.x,
      WLS.V         = WLS.V,
      NACOV         = NACOV,
      lavoptions    = lavoptions
    )
    if (lav_verbose()) {
      cat(" done.\n")
    }
  } else {
    # no data
    lavsamplestats <- new("lavSampleStats",
      ngroups = lavdata@ngroups,
      nobs = as.list(rep(0L, lavdata@ngroups)),
      cov.x = vector("list", length = lavdata@ngroups),
      mean.x = vector("list", length = lavdata@ngroups),
      th.idx = attr(lavpartable, "th.idx"),
      missing.flag = FALSE
    )
  }

  if (lav_debug()) {
    print(str(lavsamplestats))
  }

  lavsamplestats
}

# generate a parameter table for an EFA model
#
# YR 20 Sept 2022: initial verion
lav_partable_generate_efa <- function(ov.names = NULL,
                                      nfactors = 1L,
                                      meanstructure = FALSE,
                                      varTable = NULL) {
  # currently, we support only a single block (but we plan for more)
  nblocks <- 1L
  ov.names <- list(ov.names)

  # currently, we only support continuous data (but ordered is planned)
  stopifnot(is.null(ordered))

  lhs <- rhs <- op <- character(0)
  block <- free <- integer(0)
  ustart <- numeric(0)

  # create factor names
  lv.names <- paste("f", 1:nfactors, sep = "")

  # block number
  for (b in seq_len(nblocks)) {
    # ov.names for this block
    OV.NAMES <- ov.names[[b]]
    nvar <- length(OV.NAMES)
    nel <- nvar * nfactors

    # get 'ordered' variables from varTable
    categorical <- FALSE
    if (!is.null(varTable)) {
      ov.names.ord <-
        as.character(varTable$name[varTable$type == "ordered"])
      # remove those that do appear in the model syntax
      idx <- which(!ov.names.ord %in% OV.NAMES)
      if (length(idx) > 0L) {
        ov.names.ord <- ov.names.ord[-idx]
      }
      if (length(ov.names.ord) > 0L) {
        ov.names.ord <- OV.NAMES[OV.NAMES %in% ov.names.ord]
        categorical <- TRUE
      }
    }

    # a) factor loadings
    lhs <- c(lhs, rep(lv.names, each = nvar))
    op <- c(op, rep("=~", nel))
    rhs <- c(rhs, rep(OV.NAMES, times = nfactors))
    block <- c(block, rep(b, nel))
    # group <- c(group,  rep(1L,   nel))
    # level <- c(level,  rep(1L,   nel))
    free <- c(free, rep(1L, nel)) # for now
    ustart <- c(ustart, rep(as.numeric(NA), nel))

    # b) ov variances
    lhs <- c(lhs, OV.NAMES)
    op <- c(op, rep("~~", nvar))
    rhs <- c(rhs, OV.NAMES)
    block <- c(block, rep(b, nvar))
    # group <- c(group, rep(1L,   nvar))
    # level <- c(level, rep(1L,   nvar))
    free <- c(free, rep(1L, nvar))
    ustart <- c(ustart, rep(as.numeric(NA), nvar))

    # c) lv variances
    lhs <- c(lhs, lv.names)
    op <- c(op, rep("~~", nfactors))
    rhs <- c(rhs, lv.names)
    block <- c(block, rep(b, nfactors))
    # group <- c(group,  rep(1L,   nfactors))
    # level <- c(level,  rep(1L,   nfactors))
    free <- c(free, rep(0L, nfactors)) # standardized!
    ustart <- c(ustart, rep(1, nfactors))

    # d) lv covariances
    pstar <- nfactors * (nfactors - 1) / 2
    if (pstar > 0L) { # only if more than 1 variable
      tmp <- utils::combn(lv.names, 2)
      lhs <- c(lhs, tmp[1, ]) # to fill upper.tri
      op <- c(op, rep("~~", pstar))
      rhs <- c(rhs, tmp[2, ])
      block <- c(block, rep(b, pstar))
      # group  <- c(group,  rep(g,    pstar))
      # level  <- c(level,  rep(l,    pstar))
      free <- c(free, rep(1L, pstar)) # to be changed...
      ustart <- c(ustart, rep(as.numeric(NA), pstar))
    }

    if (meanstructure) {
      # e) ov means/intercepts
      lhs <- c(lhs, OV.NAMES)
      op <- c(op, rep("~1", nvar))
      rhs <- c(rhs, rep("", nvar))
      block <- c(block, rep(b, nvar))
      # group <- c(group,  rep(1L,   nvar))
      # level <- c(level,  rep(1L,   nvar))
      free <- c(free, rep(1L, nvar))
      ustart <- c(ustart, rep(as.numeric(NA), nvar))

      # f) lv means/intercepts
      lhs <- c(lhs, lv.names)
      op <- c(op, rep("~1", nfactors))
      rhs <- c(rhs, rep("", nfactors))
      block <- c(block, rep(b, nfactors))
      # group <- c(group,  rep(1L,   nfactors))
      # level <- c(level,  rep(1L,   nfactors))
      free <- c(free, rep(0L, nfactors))
      ustart <- c(ustart, rep(0, nfactors))
    } # meanstructure
  } # blocks

  # create LIST
  LIST <- list(
    id = 1:length(lhs),
    lhs = lhs,
    op = op,
    rhs = rhs,
    user = rep(0L, length(lhs)), # all system-generated
    block = block,
    group = rep(1L, length(lhs)),
    # level       = level,
    free = free,
    ustart = ustart,
    exo = rep(0L, length(lhs)),
    label = rep("", length(lhs)),
    efa = rep("", length(lhs))
  )

  # add 'efa' column with a single block string (i.e., "efa")
  LIST$efa[LIST$op == "=~"] <- "efa"

  # take care of EFA constraints
  LIST <- lav_partable_efa_constraints(LIST)

  # free counter
  idx.free <- which(LIST$free > 0)
  LIST$free[idx.free] <- seq_along(idx.free)

  # needed?
  LIST <- lav_partable_complete(LIST)

  LIST
}

# handle EFA equality constraints
# YR 14 Jan 2020: 0.6-6 does no longer impose 'explicit' constraints
#                 if we only need to fix a parameter to 0/1
# Note: we should also check if they are really needed:
#       eg., if all the factor-loadings of the 'second' set (time/group)
#       are constrained to be equal to the factor-loadings of the first
#       set, no further constraints are needed
lav_partable_efa_constraints <- function(LIST = NULL,
                                         orthogonal.efa = FALSE,
                                         group.equal = character(0L)) {
  # for each set, for each block
  nblocks <- lav_partable_nblocks(LIST)
  set.names <- lav_partable_efa_values(LIST)
  nsets <- length(set.names)

  for (b in seq_len(nblocks)) {
    for (s in seq_len(nsets)) {
      # lv's for this block/set
      lv.nam.efa <- unique(LIST$lhs[LIST$op == "=~" &
        LIST$block == b &
        LIST$efa == set.names[s]])
      if (length(lv.nam.efa) == 1L) {
        # nothing to do (warn?)
        next
      }

      # equality constraints on ALL factor loadings in this set?
      # two scenario's:
      # 1. eq constraints within the same block, perhaps time1/time2/
      # 2. eq constraints across groups (group.equal = "loadings")
      # --> no constraints are needed

      # store labels (if any)
      fix.to.zero <- TRUE

      # 1. within block/group
      if (s == 1L) {
        set.idx <- which(LIST$op == "=~" &
          LIST$block == b &
          LIST$lhs %in% lv.nam.efa)
        LABEL.set1 <- LIST$label[set.idx]
      } else {
        # collect labels for this set, if any
        set.idx <- which(LIST$op == "=~" &
          LIST$block == b &
          LIST$lhs %in% lv.nam.efa)

        # user-provided labels (if any)
        this.label.set <- LIST$label[set.idx]

        # same as in reference set?
        if (all(nchar(this.label.set) > 0L) &&
          all(this.label.set %in% LABEL.set1)) {
          fix.to.zero <- FALSE
        }
      }

      # 2. across groups
      if (b == 1L) {
        set.idx <- which(LIST$op == "=~" &
          LIST$block == b &
          LIST$lhs %in% lv.nam.efa)
        LABEL.group1 <- LIST$label[set.idx]
      } else {
        if ("loadings" %in% group.equal) {
          fix.to.zero <- FALSE
        } else {
          # collect labels for this set, if any
          set.idx <- which(LIST$op == "=~" &
            LIST$block == b &
            LIST$lhs %in% lv.nam.efa)

          # user-provided labels (if any)
          this.label.set <- LIST$label[set.idx]

          # same as in reference set?
          if (all(nchar(this.label.set) > 0L) &&
            all(this.label.set %in% LABEL.group1)) {
            fix.to.zero <- FALSE
          }
        }
      }

      # 1. echelon pattern
      nfac <- length(lv.nam.efa)
      for (f in seq_len(nfac)) {
        if (f == 1L) {
          next
        }
        nzero <- (f - 1L)
        ind.idx <- which(LIST$op == "=~" &
          LIST$block == b &
          LIST$lhs %in% lv.nam.efa[f])
        if (length(ind.idx) < nzero) {
          lav_msg_stop(gettextf(
            "efa factor %s has not enough indicators for echelon pattern",
            lv.nam.efa[f]))
        }

        # fix to zero
        if (fix.to.zero) {
          LIST$free[ind.idx[seq_len(nzero)]] <- 0L
          LIST$ustart[ind.idx[seq_len(nzero)]] <- 0
          LIST$user[ind.idx[seq_len(nzero)]] <- 7L
        } else {
          LIST$user[ind.idx[seq_len(nzero)]] <- 77L
        }
      }

      # 2. covariances constrained to zero (only if oblique rotation)
      if (!orthogonal.efa) {
        # skip if user == 1 (user-override!)
        cov.idx <- which(LIST$op == "~~" &
          LIST$block == b &
          LIST$user == 0L &
          LIST$lhs %in% lv.nam.efa &
          LIST$rhs %in% lv.nam.efa &
          LIST$lhs != LIST$rhs)

        # fix to zero
        if (fix.to.zero) {
          LIST$free[cov.idx] <- 0L
          LIST$ustart[cov.idx] <- 0
          LIST$user[cov.idx] <- 7L
        } else {
          LIST$user[cov.idx] <- 77L
        }
      }
    } # sets
  } # blocks

  LIST
}

lav_lavaan_step10_cache <- function(slotCache = NULL, # nolint
                                    lavdata = NULL,
                                    lavmodel = NULL,
                                    lavpartable = NULL,
                                    lavoptions = NULL,
                                    sampling.weights = NULL) {
  # # # # # # # # # # #
  # #  10. lavcache # #
  # # # # # # # # # # #

  # if slotCache not NULL
  #   copy to lavcache
  # else
  #   lavcache = list of length lavdata@ngroups
  #   set tmp.ov.types = lavdata$ov$types
  #   if lavmodel@conditional.x and sum(lavmodel@nexo) > 0L remove elements
  #     lavpta$vidx$ov.x from tmp.ov.types
  #   if lavoptions$estimator == "PML" and all tmp.ov.types are "ordered"
  #     th = lav_model_th(lavmodel)
  #     bi = lav_tables_pairwise_freq_cells(lavdata)
  #     if lavoptions$missing is "available.cases" or "doubly.robust"
  #       uni = lav_tables_univariate_freq_cell(lavdata)
  #       if lavoptions$missing is "doubly.robust"
  #         if lavoptions$control$pairwiseProbGivObs NULL: *** error ***
  #         if lavoptions$control$univariateProbGivObs NULL: *** error ***
  #     for all groups (1:lavdata@ngroups)
  #       set tmp.idx = 1:length(bi$ibs.freq)
  #       if bi$group not NULL and max(bi$group) > 1L set tmp.idx = indexes
  #         for this group in bi
  #       set bifreq = bi$obs.freq[tmp.idx]
  #       set binobs = bi$nobs[tmp.idx]
  #       set long = lav_pml_longvec_ind(no.x = ncol(lavdata@X[[g]]),
  #                             all.thres = th[[g]],
  #                             index.var.of.thres = lavmodel@th.idx[[g]])
  #       set lavcache[[g]] = list(bifreq = bifreq, nobs = binobs, long = long)
  #       if sampling.weights not NULL
  #         compute (for group g) lavcache[[g]]$sum_obs_weights_xixj_ab_vec (*)
  #       if lavoptions$missing is "available.cases" or "doubly.robust"
  #         set tmp.idx = 1:length(bi$ibs.freq)
  #         if bi$group not NULL and max(bi$group) > 1L set tmp.idx = indexes
  #           for this group in bi
  #         set lavcache[[g]]$unifreq = unifreq = uni$obs.freq[tmp.idx]
  #         set lavcache[[g]]$uninobs = uninobs = uni$nobs[tmp.idx]
  #         set lavcache[[g]]$uniweights.casewise = uniweights.casewise =
  #           rowSums(is.na(lavdata@X[[g]]))
  #         compute lavcache[[g]]$uniweights (*)
  #       if lavoptions$missing is "doubly.robust"
  #         lavcache[[g]]$pairwiseProbGivObs =
  #           lavoptions$control$pairwiseProbGivObs[[g]]
  #         lavcache[[g]]$univariateProbGivObs =
  #           lavoptions$control$univariateProbGivObs[[g]]
  #         compute members idx.y1, idx.gy2, idx.cat.y1, idx.cat.gy2 and
  #           id.uniPrGivObs from
  #           lavchache[[g]] (*)
  #   if lavdata$data.type is "full" and lavdata@Rp[[1L]] not NULL
  #     copy lavdata@Rp[[g]]$pat to lavcache[[g]]$pat for all groups g
  # if lavoptions$estimator is "MML"
  #   compute for all groups g lavcache[[g]]$GH via
  #     lav_integration_gauss_hermite
  #
  # (*) !!! computations too complicated to summarize here !!!

  if (!is.null(slotCache)) {
    lavcache <- slotCache
  } else {
    # prepare cache -- stuff needed for estimation, but also post-estimation
    lavcache <- vector("list", length = lavdata@ngroups)

    # ov.types? (for PML check)
    tmp.ov.types <- lavdata@ov$type
    if (lavmodel@conditional.x && sum(lavmodel@nexo) > 0L) {
      # remove ov.x
      tmp.ov.x.idx <- unlist(attr(lavpartable, "vidx")$ov.x)
      tmp.ov.types <- tmp.ov.types[-tmp.ov.x.idx]
    }

    if (lavoptions$estimator == "PML" && all(tmp.ov.types == "ordered")) {
      th <- lav_model_th(lavmodel)
      bi <- lav_tables_pairwise_freq_cell(lavdata)

      # handle option missing = "available.cases" or "doubly.robust"
      if (lavoptions$missing == "available.cases" ||
        lavoptions$missing == "doubly.robust") {
        uni <- lav_tables_univariate_freq_cell(lavdata)
        # checks for missing = "double.robust"
        if (lavoptions$missing == "doubly.robust") {
          # check whether the probabilities pairwiseProbGivObs and
          # univariateProbGivObs are given by the user
          if (is.null(lavoptions$control$pairwiseProbGivObs)) {
            lav_msg_stop(gettext(
              "could not find `pairwiseProbGivObs' in control() list"))
          }
          if (is.null(lavoptions$control$univariateProbGivObs)) {
            lav_msg_stop(gettext(
              "could not find `univariateProbGivObs' in control() list"))
          }
        }
      }

      for (g in 1:lavdata@ngroups) {
        if (is.null(bi$group) || max(bi$group) == 1L) {
          bifreq <- bi$obs.freq
          binobs <- bi$nobs
        } else {
          idx <- which(bi$group == g)
          bifreq <- bi$obs.freq[idx]
          binobs <- bi$nobs[idx]
        }
        long <- lav_pml_longvec_ind(
          no.x = ncol(lavdata@X[[g]]),
          all.thres = th[[g]],
          index.var.of.thres = lavmodel@th.idx[[g]]
        )
        lavcache[[g]] <- list(
          bifreq = bifreq,
          nobs = binobs,
          long = long
        )

        # >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

        # I need to add something that splits weights into g groups so
        # adjust what follows in the new code also compute the sum of
        # weights within a group, this will substitute n_g (group size)
        # of simple random sampling (SRS) and also compute the total the
        # total sum of weights over all observation over all groups,
        # this substitutes the total sample size of SRS.

        if (!is.null(sampling.weights)) {
          # Keep track of indices of the response categories (a,b) of a
          # pair of ordinal variables (xi,xj) appearing in the data as
          # well as the index of the pair.
          idx_ab_of_xixj_ab <- lapply(long[c(1:2, 5)], function(x) {
            x[(long$index.thres.var1.of.pair != 0) &
              (long$index.thres.var2.of.pair != 0)]
          })
          names(idx_ab_of_xixj_ab) <- c("idx_a", "idx_b", "idx_pairs")
          lavcache[[g]]$idx_ab_of_xixj_ab <- idx_ab_of_xixj_ab

          # Raw data for group g
          X.g <- lavdata@X[[g]] # nolint

          # I assume that X.g includes only the ordinal indicators nvar
          # gives the number of ordinal indicators
          nvar <- ncol(X.g)

          # pstar gives the number of pairs formed by the nvar ordinal
          # indicators
          pstar <- nvar * (nvar - 1) / 2

          # Keep track of the indices of variables forming each pair
          idx_vars_in_pair <- combn(nvar, 2)

          # The output of sapply below provides the sum of weights for
          # all bivariate response pattern for all pairs of indicators.

          # If all indicators have the same number of response
          # categories, the output of sapply function below is a matrix.
          # Each column refers to a different pair of indicators (i,j)
          # with j running faster than i, e.g. (1,2) (1,3) (2,3). Within
          # each column, each element (i.e. each row of the matrix)
          # refers to a different combination of response categories
          # (a,b) with a, the category index of indicator i, running
          # faster than b, the category index of indicator j, e.g.
          # (1,1), (2,1) (3,1) (1,2) (2,2) (3,2)

          # If the indicators have different number of response
          # categories, the output of sapply function below is a list.
          # Each element of the list refers to a different pair of
          # indicators (i,j) with j running faster than i and it is a
          # matrix with number of rows the number of response categories
          # of indicator i and ncol =  the number of response categories
          # of indicator j.

          sum_obs_weights_xixj_ab <- sapply(1:pstar, function(x) {
            tmp_idx_ab <- lapply(idx_ab_of_xixj_ab, function(y) {
              y[idx_ab_of_xixj_ab$idx_pairs == x]
            })
            tmp_idx_cols <- idx_vars_in_pair[, x]
            tmp_var1 <- factor(X.g[, tmp_idx_cols[1]],
              levels =
                as.character(unique(tmp_idx_ab$idx_a))
            )
            tmp_var2 <- factor(X.g[, tmp_idx_cols[2]],
              levels =
                as.character(unique(tmp_idx_ab$idx_b))
            )
            tapply(
              X = lavdata@weights[[g]],
              INDEX = list(tmp_var1, tmp_var2),
              FUN = sum
            )
          })

          # We need to transform the output of sapply into a vector
          # where the sum of weights (for all bivariate response
          # patterns for all pairs of indicators) are listed in the same
          # order as in pairwisePI vector, i.e. a runs the fastest,
          # followed by b, then by j and lastly by i.

          if (is.matrix(sum_obs_weights_xixj_ab)) {
            sum_obs_weights_xixj_ab_vec <- c(sum_obs_weights_xixj_ab)
          } else if (is.list(sum_obs_weights_xixj_ab)) {
            sum_obs_weights_xixj_ab_vec <-
              do.call(c, sum_obs_weights_xixj_ab)
          }

          # Note that sapply gives NA for these bivariate response
          # patterns which are not observed at all. Substitute NA with
          # 0.
          idx_na_sowxav <- is.na(sum_obs_weights_xixj_ab_vec)
          if (any(idx_na_sowxav)) {
            sum_obs_weights_xixj_ab_vec[idx_na_sowxav] <- 0
          }

          lavcache[[g]]$sum_obs_weights_xixj_ab_vec <-
            sum_obs_weights_xixj_ab_vec
        }

        # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

        # available cases
        if (lavoptions$missing == "available.cases" ||
          lavoptions$missing == "doubly.robust") {
          if (is.null(uni$group) || max(uni$group) == 1L) {
            unifreq <- uni$obs.freq
            uninobs <- uni$nobs
          } else {
            idx <- which(uni$group == g)
            unifreq <- uni$obs.freq[idx]
            uninobs <- uni$nobs[idx]
          }
          lavcache[[g]]$unifreq <- unifreq
          lavcache[[g]]$uninobs <- uninobs

          uniweights.casewise <- rowSums(is.na(lavdata@X[[g]]))
          lavcache[[g]]$uniweights.casewise <- uniweights.casewise

          # weights per response category per variable in the same
          # order as unifreq; i.e. w_ia, i = 1,...,p, (p variables),
          # a = 1,...,Ci, (Ci response categories for variable i),
          # a running faster than i
          tmp.uniweights <- apply(
            lavdata@X[[g]], 2,
            function(x) {
              tapply(uniweights.casewise, as.factor(x), sum,
                na.rm = TRUE
              )
            }
          )
          if (is.matrix(tmp.uniweights)) {
            lavcache[[g]]$uniweights <- c(tmp.uniweights)
          }
          if (is.list(tmp.uniweights)) {
            lavcache[[g]]$uniweights <- unlist(tmp.uniweights)
          }
        } # "available.cases" or "double.robust"

        # doubly.robust only
        if (lavoptions$missing == "doubly.robust") {
          # add the provided by the user probabilities
          # pairwiseProbGivObs and univariateProbGivObs in Cache
          lavcache[[g]]$pairwiseProbGivObs <-
            lavoptions$control$pairwiseProbGivObs[[g]]
          lavcache[[g]]$univariateProbGivObs <-
            lavoptions$control$univariateProbGivObs[[g]]
          # compute different indices vectors that will help to do
          # calculations
          ind.vec <- as.data.frame(long[1:5])
          ind.vec <-
            ind.vec[((ind.vec$index.thres.var1.of.pair != 0) &
              (ind.vec$index.thres.var2.of.pair != 0)), ]
          idx.cat.y1 <- ind.vec$index.thres.var1.of.pair
          idx.cat.y2 <- ind.vec$index.thres.var2.of.pair
          idx.pairs <- ind.vec$index.pairs.extended
          lavcache[[g]]$idx.pairs <- idx.pairs

          idx.cat.y1.split <- split(idx.cat.y1, idx.pairs)
          idx.cat.y2.split <- split(idx.cat.y2, idx.pairs)
          lavcache[[g]]$idx.cat.y1.split <- idx.cat.y1.split
          lavcache[[g]]$idx.cat.y2.split <- idx.cat.y2.split

          # generate the variables, categories indices vector which
          # keep track to which variables and categories the
          # elements of vector probY1Gy2 refer to
          nlev <- lavdata@ov$nlev
          nvar <- length(nlev)

          idx.var.matrix <- matrix(1:nvar, nrow = nvar, ncol = nvar)
          idx.diag <- diag(matrix(1:(nvar * nvar),
            nrow = nvar,
            ncol = nvar
          ))
          idx.y1gy2.matrix <- rbind(
            t(idx.var.matrix)[-idx.diag],
            idx.var.matrix[-idx.diag]
          )
          no.pairs.y1gy2 <- ncol(idx.y1gy2.matrix)
          idx.cat.y1 <- unlist(lapply(1:no.pairs.y1gy2, function(x) {
            rep(1:nlev[idx.y1gy2.matrix[1, x]],
              times = nlev[idx.y1gy2.matrix[2, x]]
            )
          }))
          idx.cat.gy2 <- unlist(lapply(1:no.pairs.y1gy2, function(x) {
            rep(1:nlev[idx.y1gy2.matrix[2, x]],
              each = nlev[idx.y1gy2.matrix[1, x]]
            )
          }))
          dim.pairs <- unlist(lapply(1:no.pairs.y1gy2, function(x) {
            nlev[idx.y1gy2.matrix[1, x]] *
              nlev[idx.y1gy2.matrix[2, x]]
          }))
          idx.y1 <- unlist(mapply(rep, idx.y1gy2.matrix[1, ],
            each = dim.pairs
          ))
          idx.gy2 <- unlist(mapply(rep, idx.y1gy2.matrix[2, ],
            each = dim.pairs
          ))

          lavcache[[g]]$idx.Y1 <- idx.y1
          lavcache[[g]]$idx.Gy2 <- idx.gy2
          lavcache[[g]]$idx.cat.Y1 <- idx.cat.y1
          lavcache[[g]]$idx.cat.Gy2 <- idx.cat.gy2

          # the vector below keeps track of the variable each column
          # of the matrix univariateProbGivObs refers to
          lavcache[[g]]$id.uniPrGivObs <-
            sort(c(
              unique(lavmodel@th.idx[[g]]),
              lavmodel@th.idx[[g]]
            ))
        } # doubly.robust
      } # g
    }
    # copy response patterns to cache -- FIXME!! (data not included
    # in Model only functions)
    if (lavdata@data.type == "full" && !is.null(lavdata@Rp[[1L]])) {
      for (g in 1:lavdata@ngroups) {
        lavcache[[g]]$pat <- lavdata@Rp[[g]]$pat
      }
    }
  }

  # If estimator = MML, store Gauss-Hermite nodes/weights
  if (lavoptions$estimator == "MML") {
    for (g in 1:lavdata@ngroups) {
      # count only the ones with non-normal indicators
      # nfac <- lavpta$nfac.nonnormal[[g]]
      nfac <- attr(lavpartable, "nfac")[[g]]
      lavcache[[g]]$GH <-
        lav_integration_gauss_hermite(
          n = lavoptions$integration.ngh,
          dnorm = TRUE,
          mean = 0, sd = 1,
          ndim = nfac
        )
      # lavcache[[g]]$DD <- lav_model_gradient_DD(lavmodel, group = g)
    }
  }

  lavcache
}

# YR 19 September 2022
#
# Entry function to handle noniterative estimators


lav_optim_noniter <- function(lavmodel = NULL, lavsamplestats = NULL,
                              lavpartable = NULL, lavh1 = NULL,
                              lavdata = NULL, lavoptions = NULL) {
  lavpta <- lav_partable_attributes(lavpartable)
  lavpartable <- lav_partable_set_cache(lavpartable, lavpta)

  # no support for many things:
  if (lavmodel@ngroups > 1L) {
    lav_msg_stop(gettext(
      "multiple groups not supported (yet) with optim.method = 'NONITER'."))
  }

  if (lavdata@nlevels > 1L) {
    lav_msg_stop(gettext(
      "multilevel not supported (yet) with optim.method = 'NONITER'."))
  }

  # no support (yet) for nonlinear constraints
  nonlinear.idx <- c(
    lavmodel@ceq.nonlinear.idx,
    lavmodel@cin.nonlinear.idx
  )
  if (length(nonlinear.idx) > 0L) {
    lav_msg_stop(gettext(
      "nonlinear constraints not supported (yet) with optim.method = 'NONITER'."
      ))
  }

  # no support (yet) for inequality constraints
  if (!lavmodel@cin.simple.only && !is.null(body(lavmodel@cin.function))) {
    lav_msg_stop(gettext(
    "inequality constraints not supported (yet) with optim.method = 'NONITER'."
    ))
  }

  # no support (yet) for equality constraints
  if (length(lavmodel@ceq.linear.idx) > 0L) {
    lav_msg_stop(gettext(
      "equality constraints not supported (yet) with optim.method = 'NONITER'."
      ))
  }

  # extract current set of free parameters
  x.old <- lav_model_get_parameters(lavmodel)
  npar <- length(x.old)


  # fabin?
  ok.flag <- FALSE
  if (lavoptions$estimator %in% c("FABIN2", "FABIN3")) {
    x <- try(lav_cfa_fabin_internal(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavpartable = lavpartable,
      lavoptions = lavoptions
    ), silent = TRUE)
  } else if (lavoptions$estimator == "MGM") {
    x <- try(lav_cfa_guttman1952_internal(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavpartable = lavpartable,
      lavoptions = lavoptions
    ), silent = TRUE)
  } else if (lavoptions$estimator == "BENTLER1982") {
    x <- try(lav_cfa_bentler1982_internal(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavpartable = lavpartable,
      lavoptions = lavoptions
    ), silent = TRUE)
  } else if (lavoptions$estimator %in% c("JS", "JSA")) {
    x <- try(lav_cfa_jamesstein_internal(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavpartable = lavpartable,
      lavdata = lavdata,
      lavoptions = lavoptions
    ), silent = TRUE)
  } else if (lavoptions$estimator == "BENTLER1982") {
    x <- try(lav_cfa_bentler1982_internal(
      lavmodel = lavmodel,
      lavsamplestats = lavsamplestats, lavpartable = lavpartable,
      lavoptions = lavoptions
    ), silent = TRUE)
  } else if (lavoptions$estimator == "IV") {
    x <- try(lav_sem_miiv_internal(
      lavmodel = lavmodel, lavdata = lavdata, lavh1 = lavh1,
      lavsamplestats = lavsamplestats, lavpartable = lavpartable,
      lavoptions = lavoptions
    ), silent = TRUE)
  } else {
    lav_msg_warn(
      gettextf("unknown (noniterative) estimator: %s
               (returning starting values)", lavoptions$estimator)
    )
  }
  if (inherits(x, "try-error")) {
    x <- x.old
  } else {
    ok.flag <- TRUE
  }

  # closing
  fx <- 0
  attr(fx, "fx.group") <- rep(0, lavmodel@ngroups)
  if (ok.flag) {
    attr(x, "converged") <- TRUE
    attr(x, "warn.txt") <- ""
  } else {
    attr(x, "converged") <- FALSE
    attr(x, "warn.txt") <- "noniterative estimation failed"
  }
  attr(x, "iterations") <- 1L
  attr(x, "control") <- list()
  attr(x, "fx") <- fx

  x
}

# compute the loglikelihood of the data, given the current values of the
# model parameters
lav_model_loglik <- function(lavdata = NULL,
                             lavsamplestats = NULL,
                             lavh1 = NULL,
                             lavimplied = NULL,
                             lavmodel = NULL,
                             lavoptions = NULL) {
  ngroups <- lavdata@ngroups

  logl.group <- rep(as.numeric(NA), ngroups)

  # should compute logl, or return NA?
  logl.ok <- FALSE
  if (lavoptions$estimator %in% c("ML", "MML")) {
    # check if everything is numeric, OR if we have exogenous
    # factor with 2 levels only
    # if(all(lavdata@ov$type == "numeric")) {
    logl.ok <- TRUE
    # } else {
    if (lavoptions$fixed.x == FALSE) {
      exo.idx <- which(lavdata@ov$exo == 1L)
      for (i in exo.idx) {
        if (lavdata@ov$nlev[i] > 1L) {
          logl.ok <- FALSE
        }
      }
    }
    # nlevels + fiml
    # if(lavdata@nlevels > 1L && lavsamplestats@missing.flag) {
    #    logl.ok <- FALSE
    # }
  }

  # lavsamplestats filled in? (not if no data, or samplestats = FALSE)
  if (length(lavsamplestats@ntotal) == 0L ||
      (!is.null(lavoptions$samplestats) && !lavoptions$samplestats)) {
    logl.ok <- FALSE
  }

  # catch all-zero Sigma (new in 0.6-20)
  nblocks <- lavmodel@nblocks
  for (b in seq_len(nblocks)) {
    if (lavmodel@conditional.x) {
      if (all(lavimplied$res.cov[[b]] == 0)) {
        logl.ok <- FALSE
      }
    } else {
      if (all(lavimplied$cov[[b]] == 0)) {
        logl.ok <- FALSE
      }
    }
  }


  if (logl.ok) {
    for (g in seq_len(ngroups)) {
      if (lavdata@nlevels > 1L) {
        # here, we assume only 2 levels, at [[1]] and [[2]]
        if (lavmodel@conditional.x) {
          Res.Sigma.W <- lavimplied$res.cov[[(g - 1) * 2 + 1]]
          Res.Int.W <- lavimplied$res.int[[(g - 1) * 2 + 1]]
          Res.Pi.W <- lavimplied$res.slopes[[(g - 1) * 2 + 1]]

          Res.Sigma.B <- lavimplied$res.cov[[(g - 1) * 2 + 2]]
          Res.Int.B <- lavimplied$res.int[[(g - 1) * 2 + 2]]
          Res.Pi.B <- lavimplied$res.slopes[[(g - 1) * 2 + 2]]
        } else {
          Sigma.W <- lavimplied$cov[[(g - 1) * 2 + 1]]
          Mu.W <- lavimplied$mean[[(g - 1) * 2 + 1]]
          Sigma.B <- lavimplied$cov[[(g - 1) * 2 + 2]]
          Mu.B <- lavimplied$mean[[(g - 1) * 2 + 2]]
        }

        if (lavsamplestats@missing.flag) {
          if (lavmodel@conditional.x) {
            # TODO
            logl.group[g] <- as.numeric(NA)
          } else {
            logl.group[g] <-
              lav_mvnorm_cluster_missing_loglik_samplestats_2l(
                Y1 = lavdata@X[[g]],
                Y2 = lavsamplestats@YLp[[g]][[2]]$Y2,
                Lp = lavdata@Lp[[g]],
                Mp = lavdata@Mp[[g]],
                Mu.W = Mu.W, Sigma.W = Sigma.W,
                Mu.B = Mu.B, Sigma.B = Sigma.B,
                loglik.x = lavsamplestats@YLp[[g]][[2]]$loglik.x,
                log2pi = TRUE, minus.two = FALSE
              )
          }
        } else {
          # complete case
          if (lavmodel@conditional.x) {
            logl.group[g] <-
              lav_mvreg_cluster_loglik_samplestats_2l(
                YLp          = lavsamplestats@YLp[[g]],
                Lp           = lavdata@Lp[[g]],
                Res.Sigma.W  = Res.Sigma.W,
                Res.Int.W    = Res.Int.W,
                Res.Pi.W     = Res.Pi.W,
                Res.Sigma.B  = Res.Sigma.B,
                Res.Int.B    = Res.Int.B,
                Res.Pi.B     = Res.Pi.B,
                Sinv.method  = "eigen",
                log2pi       = TRUE,
                minus.two    = FALSE
              )
          } else {
            logl.group[g] <-
              lav_mvnorm_cluster_loglik_samplestats_2l(
                YLp          = lavsamplestats@YLp[[g]],
                Lp           = lavdata@Lp[[g]],
                Mu.W         = Mu.W,
                Sigma.W      = Sigma.W,
                Mu.B         = Mu.B,
                Sigma.B      = Sigma.B,
                Sinv.method  = "eigen",
                log2pi       = TRUE,
                minus.two    = FALSE
              )
          }
        } # complete
        # end multilevel
      } else if (lavsamplestats@missing.flag) {
        x.idx <- lavsamplestats@x.idx[[g]]
        X.MEAN <- X.COV <- NULL
        if (length(x.idx) > 0L) {
          X.MEAN <- lavh1$implied$mean[[g]][x.idx]
          X.COV <- lavh1$implied$cov[[g]][x.idx, x.idx, drop = FALSE]
        }
        logl.group[g] <- lav_mvnorm_missing_loglik_samplestats(
          Yp     = lavsamplestats@missing[[g]],
          Mu     = lavimplied$mean[[g]],
          Sigma  = lavimplied$cov[[g]],
          x.idx  = lavsamplestats@x.idx[[g]],
          x.mean = X.MEAN, # not needed? should be part of Sigma
          x.cov  = X.COV
        ) # not needed at all!
      } else { # single-level, complete data
        if (lavoptions$conditional.x) {
          # FIXME: use lavh1
          logl.group[g] <- lav_mvreg_loglik_samplestats(
            sample.res.int    = lavsamplestats@res.int[[g]],
            sample.res.slopes = lavsamplestats@res.slopes[[g]],
            sample.res.cov    = lavsamplestats@res.cov[[g]],
            sample.mean.x     = lavsamplestats@mean.x[[g]],
            sample.cov.x      = lavsamplestats@cov.x[[g]],
            sample.nobs       = lavsamplestats@nobs[[g]],
            res.int           = lavimplied$res.int[[g]],
            res.slopes        = lavimplied$res.slopes[[g]],
            res.cov           = lavimplied$res.cov[[g]],
            Sinv.method       = "eigen"
          )
        } else {
          if (lavoptions$meanstructure) {
            Mu <- lavimplied$mean[[g]]
          } else {
            Mu <- lavsamplestats@mean[[g]]
          }
          logl.group[g] <- lav_mvnorm_loglik_samplestats(
            sample.mean = lavsamplestats@mean[[g]],
            sample.cov  = lavsamplestats@cov[[g]],
            sample.nobs = lavsamplestats@nobs[[g]],
            Mu          = Mu,
            Sigma       = lavimplied$cov[[g]],
            x.idx       = lavsamplestats@x.idx[[g]],
            x.mean      = lavsamplestats@mean.x[[g]],
            x.cov       = lavsamplestats@cov.x[[g]],
            Sinv.method = "eigen",
            Sigma.inv   = NULL
          )
        }
      } # complete
    } # g
  } # logl.ok is TRUE

  # logl
  logl <- sum(logl.group)

  # number of parameters, taking into account any equality constraints
  npar <- lavmodel@nx.free
  ceq.simple.only <- lavmodel@ceq.simple.only
  cin.simple.only <- lavmodel@cin.simple.only

  if (ceq.simple.only) {
    # nothing to do
  } else if (!cin.simple.only && nrow(lavmodel@con.jac) > 0L) {
    ceq.idx <- attr(lavmodel@con.jac, "ceq.idx")
    if (length(ceq.idx) > 0L) {
      neq <- qr(lavmodel@con.jac[ceq.idx, , drop = FALSE])$rank
      npar <- npar - neq
    }
  }

  # logl
  logl <- sum(logl.group)

  if (logl.ok) {
    # AIC
    AIC <- lav_fit_aic(logl = logl, npar = npar)

    # BIC
    BIC <- lav_fit_bic(logl = logl, npar = npar, N = lavsamplestats@ntotal)

    # BIC2
    BIC2 <- lav_fit_sabic(
      logl = logl, npar = npar,
      N = lavsamplestats@ntotal
    )
  } else {
    AIC <- BIC <- BIC2 <- as.numeric(NA)
  }

  out <- list(
    loglik = logl,
    loglik.group = logl.group,
    npar = npar,
    ntotal = lavsamplestats@ntotal,
    AIC = AIC,
    BIC = BIC,
    BIC2 = BIC2,
    estimator = lavoptions$estimator,
    conditional.x = lavoptions$conditional.x,
    fixed.x = lavoptions$fixed.x
  )

  out
}

# FABIN = factor analysis by instrumental variables
# Hagglund 1982 (efa), 1986 (cfa)

lav_cfa_fabin2 <- function(S, marker.idx = NULL, lambda.nonzero.idx = NULL) {
  nvar <- ncol(S)
  nfac <- length(marker.idx)

  # overview of free/fixed
  LAMBDA <- matrix(0, nvar, nfac)
  LAMBDA[lambda.nonzero.idx] <- -1L

  lambda <- matrix(0, nvar, nfac)
  for (i in 1:nvar) {
    if (i %in% marker.idx) {
      lambda[i, marker.idx == i] <- 1.0
      next
    }
    free.idx <- LAMBDA[i, ] == -1L
    idx3 <- (1:nvar)[-c(i, marker.idx)]
    s23 <- S[i, idx3]
    fac.idx <- marker.idx[free.idx]

    if (length(fac.idx) == 1L) { # most common scenario in CFA
      S31 <- S13 <- S[idx3, fac.idx]
      lambda[i, free.idx] <- sum(s23 * S31) / sum(S13 * S13)
    } else {
      S31 <- S[idx3, fac.idx, drop = FALSE]
      S13 <- S[fac.idx, idx3, drop = FALSE]
      lambda[i, free.idx] <- solve(S13 %*% S31, drop(s23 %*% S31))
    }
  }

  lambda
}

lav_cfa_fabin3 <- function(S, marker.idx = NULL, lambda.nonzero.idx = NULL) {
  nvar <- ncol(S)
  nfac <- length(marker.idx)

  # overview of free/fixed
  LAMBDA <- matrix(0, nvar, nfac)
  LAMBDA[lambda.nonzero.idx] <- -1L

  S33.inv <- try(solve(S[-marker.idx, -marker.idx, drop = FALSE]),
    silent = TRUE
  )
  if (inherits(S33.inv, "try-error")) {
    lav_msg_warn(gettext("fabin3 failed; switching to fabin2"))
    return(lav_cfa_fabin2(
      S = S, marker.idx = marker.idx,
      lambda.nonzero.idx = lambda.nonzero.idx
    ))
  }

  lambda <- matrix(0, nvar, nfac)
  rm3.idx <- 0L
  for (i in 1:nvar) {
    if (i %in% marker.idx) {
      lambda[i, marker.idx == i] <- 1.0
      next
    }
    free.idx <- LAMBDA[i, ] == -1L
    idx3 <- (1:nvar)[-c(i, marker.idx)]
    S33 <- S[idx3, idx3, drop = FALSE]
    s23 <- S[i, idx3]
    fac.idx <- marker.idx[free.idx]
    rm3.idx <- rm3.idx + 1L
    # update inverse
    s33.inv <- lav_matrix_symmetric_inverse_update(
      S.inv = S33.inv,
      rm.idx = rm3.idx
    )

    if (length(fac.idx) == 1L) { # most common scenario in CFA
      S31 <- S13 <- S[idx3, fac.idx]
      tmp <- s33.inv %*% S31 # or colSums(s33.inv * S31)
      lambda[i, free.idx] <- sum(s23 * tmp) / sum(S13 * tmp)
    } else {
      S31 <- S[idx3, fac.idx, drop = FALSE]
      S13 <- S[fac.idx, idx3, drop = FALSE]
      tmp <- s33.inv %*% S31
      # lambda[i, free.idx] <- ( s23 %*% solve(S33) %*% S31 %*%
      #                          solve(S13 %*% solve(S33) %*% S31) )
      lambda[i, free.idx] <- solve(S13 %*% tmp, drop(s23 %*% tmp))
    }
  }

  lambda
}

# internal function to be used inside lav_optim_noniter
# return 'x', the estimated vector of free parameters
lav_cfa_fabin_internal <- function(lavmodel = NULL, lavsamplestats = NULL,
                                   lavpartable = NULL,
                                   lavdata = NULL, lavoptions = NULL) {
  lavpta <- lav_partable_attributes(lavpartable)
  lavpartable <- lav_partable_set_cache(lavpartable, lavpta)
  # no structural part!
  if (any(lavpartable$op == "~")) {
    lav_msg_stop(gettext("FABIN estimator only available for CFA models"))
  }
  # no BETA matrix! (i.e., no higher-order factors)
  if (!is.null(lavmodel@GLIST$beta)) {
    lav_msg_stop(gettext(
    "FABIN estimator not available for models that require a BETA matrix"))
  }
  # no std.lv = TRUE for now
  if (lavoptions$std.lv) {
    lav_msg_stop(
      gettext("FABIN estimator not available if std.lv = TRUE"))
  }

  nblocks <- lav_partable_nblocks(lavpartable)
  stopifnot(nblocks == 1L) # for now
  b <- 1L
  sample.cov <- lavsamplestats@cov[[b]]
  nvar <- nrow(sample.cov)
  lv.names <- lavpta$vnames$lv.regular[[b]]
  nfac <- length(lv.names)
  marker.idx <- lavpta$vidx$lv.marker[[b]]
  lambda.idx <- which(names(lavmodel@GLIST) == "lambda")
  lambda.nonzero.idx <- lavmodel@m.free.idx[[lambda.idx]]
  # only diagonal THETA for now...
  # because if we have correlated residuals, we should remove the
  # corresponding variables as instruments before we estimate lambda...
  # (see MIIV)
  theta.idx <- which(names(lavmodel@GLIST) == "theta") # usually '2'
  m.theta <- lavmodel@m.free.idx[[theta.idx]]
  nondiag.idx <- m.theta[!m.theta %in% lav_matrix_diag_idx(nvar)]
  if (length(nondiag.idx) > 0L) {
    lav_msg_warn(gettext(
      "this implementation of FABIN does not handle correlated residuals yet!"
      ))
  }

  # 1. estimate LAMBDA
  if (lavoptions$estimator == "FABIN2") {
    LAMBDA <- lav_cfa_fabin2(
      S = sample.cov, marker.idx = marker.idx,
      lambda.nonzero.idx = lambda.nonzero.idx
    )
  } else {
    LAMBDA <- lav_cfa_fabin3(
      S = sample.cov, marker.idx = marker.idx,
      lambda.nonzero.idx = lambda.nonzero.idx
    )
  }

  # 2. simple ULS method to get THETA and PSI (for now)
  GLS.flag <- FALSE
  psi.mapping.ML.flag <- FALSE
  if (!is.null(lavoptions$estimator.args$thetapsi.method) &&
    lavoptions$estimator.args$thetapsi.method %in% c("GLS", "GLS.ML")) {
    GLS.flag <- TRUE
  }
  if (!is.null(lavoptions$estimator.args$thetapsi.method) &&
    lavoptions$estimator.args$thetapsi.method %in% c("ULS.ML", "GLS.ML")) {
    psi.mapping.ML.flag <- TRUE
  }
  out <- lav_cfa_lambda2thetapsi(
    lambda = LAMBDA, S = sample.cov,
    S.inv = lavsamplestats@icov[[b]],
    GLS = GLS.flag,
    psi.mapping.ML = psi.mapping.ML.flag,
    nobs = lavsamplestats@ntotal
  )
  THETA <- diag(out$theta)
  PSI <- out$psi

  # 3. correlated residuals (if any) are just the difference between
  #    Sigma and S
  # if(length(nondiag.idx) > 0L) {
  #    Sigma <- LAMBDA %*% PSI %*% t(LAMBDA) + THETA
  #    THETA[nondiag.idx] <- (sample.cov - Sigma)[nondiag.idx]
  # }

  # store matrices in lavmodel@GLIST
  lavmodel@GLIST$lambda <- LAMBDA
  lavmodel@GLIST$theta <- THETA
  lavmodel@GLIST$psi <- PSI

  # extract free parameters only
  x <- lav_model_get_parameters(lavmodel)

  # apply bounds (if any)
  if (!is.null(lavpartable$lower)) {
    lower.x <- lavpartable$lower[lavpartable$free > 0]
    too.small.idx <- which(x < lower.x)
    if (length(too.small.idx) > 0L) {
      x[too.small.idx] <- lower.x[too.small.idx]
    }
  }
  if (!is.null(lavpartable$upper)) {
    upper.x <- lavpartable$upper[lavpartable$free > 0]
    too.large.idx <- which(x > upper.x)
    if (length(too.large.idx) > 0L) {
      x[too.large.idx] <- upper.x[too.large.idx]
    }
  }

  x
}

# data.frame utilities
# Y.R. 11 April 2013

# - 10 nov 2019: * removed lav_dataframe_check_vartype(), as we can simply use
#                  sapply(lapply(frame, class), "[", 1L) (unused anyway)
#                * removed lav_dataframe_check_ordered() as we can simply use
#                  any(sapply(frame[, ov.names], inherits, "ordered"))

# construct vartable, but allow 'ordered/factor' argument to intervene
# we do NOT change the data.frame
lav_dataframe_vartable <- function(frame = NULL, ov.names = NULL,
                                   ov.names.x = NULL,
                                   ordered = NULL,
                                   factor = NULL,
                                   as.data.frame. = FALSE,
                                   allow.empty.cell = FALSE) {
  if (missing(ov.names)) {
    var.names <- names(frame)
  } else {
    ov.names <- unlist(ov.names, use.names = FALSE)
    ov.names.x <- unlist(ov.names.x, use.names = FALSE)
    var.names <- unique(c(ov.names, ov.names.x))
  }
  nvar <- length(var.names)
  var.idx <- match(var.names, names(frame))


  nobs <- integer(nvar)
  type <- character(nvar)
  user <- integer(nvar)
  exo <- ifelse(var.names %in% ov.names.x, 1L, 0L)
  mean <- numeric(nvar)
  var <- numeric(nvar)
  nlev <- integer(nvar)
  lnam <- character(nvar)
  for (i in seq_len(nvar)) {
    x <- frame[[var.idx[i]]]

    type.x <- class(x)[1L]

    # correct for matrix with 1 column
    if (inherits(x, "matrix") && (is.null(dim(x)) ||
      (!is.null(dim) && ncol(x) == 1L))) {
      type.x <- "numeric"
    }

    # correct for integers
    if (inherits(x, "integer")) {
      type.x <- "numeric"
    }

    # handle the 'labelled' type from the haven package
    # - if the variable name is not in 'ordered', we assume
    #   it is numeric (for now) 11 March 2018
    if (inherits(x, "labelled") && !(var.names[i] %in% ordered)) {
      type.x <- "numeric"
    }

    # handle ordered/factor
    if (!is.null(ordered) && var.names[i] %in% ordered) {
      type.x <- "ordered"
      if (allow.empty.cell) {
        if (inherits(x, 'factor')) {
          nlev[i] <- nlevels(x)
          lnam[i] <- paste(levels(x), collapse = "|")
        } else {
          nlev[i] <- max(as.numeric(x), na.rm = TRUE)
          lnam[i] <- paste(1:nlev[i], collapse = "|")
        }
      } else {
        lev <- sort(unique(x)) # we assume integers!
        nlev[i] <- length(lev)
        lnam[i] <- paste(lev, collapse = "|")
      }
      user[i] <- 1L
    } else if (!is.null(factor) && var.names[i] %in% factor) {
      type.x <- "factor"
      lev <- sort(unique(x)) # we assume integers!
      nlev[i] <- length(lev)
      lnam[i] <- paste(lev, collapse = "|")
      user[i] <- 1L
    } else {
      nlev[i] <- nlevels(x)
      lnam[i] <- paste(levels(x), collapse = "|")
    }

    type[i] <- type.x
    nobs[i] <- sum(!is.na(x))
    mean[i] <- ifelse(type.x == "numeric", mean(x, na.rm = TRUE),
      as.numeric(NA)
    )
    var[i] <- ifelse(type.x == "numeric", var(x, na.rm = TRUE),
      as.numeric(NA)
    )
  }

  VAR <- list(
    name = var.names, idx = var.idx, nobs = nobs, type = type, exo = exo,
    user = user, mean = mean, var = var, nlev = nlev, lnam = lnam
  )

  if (as.data.frame.) {
    VAR <- as.data.frame(VAR,
      stringsAsFactors = FALSE,
      row.names = 1:length(VAR$name)
    )
    class(VAR) <- c("lavaan.data.frame", "data.frame")
  }

  VAR
}

lav_lavaan_step09_model <- function(slotModel = NULL, # nolint
                                    lavoptions = NULL,
                                    lavpartable = NULL,
                                    lavsamplestats = NULL,
                                    lavdata = NULL) {
  # # # # # # # # # # #
  # #  9. lavmodel # #
  # # # # # # # # # # #

  # if slotModel not NULL
  #   copy to lavmodel
  # else
  #   compute lavmodel via lav_model
  #   if lavdata@data.type == "none" and categorical mode
  #     set parameters in lavmodel via lav_model_set_parameters and
  #       re-adjust start column in lavpartable
  #     if differences between start and ustart column (in lavpartable)
  #       if lavmodel$parameterization == "delta"
  #         if user specified delta values : ** warning **
  #       if lavmodel$parameterization == "theta"
  #         if user specified theta values : ** warning **

  if (!is.null(slotModel)) {
    lavmodel <- slotModel
  } else {
    if (lav_verbose()) {
      cat("lavmodel           ...")
    }
    lavmodel <- lav_model(
      lavpartable = lavpartable,
      lavoptions = lavoptions,
      th.idx = lavsamplestats@th.idx
    )
    # no longer needed: x values are in start
    # cov.x            = lavsamplestats@cov.x,
    # mean.x           = lavsamplestats@mean.x)

    # if no data, call lav_model_set_parameters once (for categorical case)
    if (lavdata@data.type == "none" && lavmodel@categorical) {
      lavmodel <- lav_model_set_parameters(
        lavmodel = lavmodel,
        x = lav_model_get_parameters(lavmodel)
      )
      # re-adjust parameter table
      lavpartable$start <- lav_model_get_parameters(lavmodel, type = "user")

      # check/warn if theta/delta values make sense
      if (!all(lavpartable$start == lavpartable$ustart)) {
        if (lavmodel@parameterization == "delta") {
          # did the user specify theta values?
          user.var.idx <- which(lavpartable$op == "~~" &
            lavpartable$lhs == lavpartable$rhs &
            lavpartable$lhs %in% unlist(attr(lavpartable, "vnames")$ov.ord) &
            lavpartable$user == 1L)
          if (length(user.var.idx)) {
            lav_msg_warn(
              gettextf("variance (theta) values for categorical variables
                       are ignored if parameterization = %s!",
                       "'delta'")
            )
          }
        } else if (lavmodel@parameterization == "theta") {
          # did the user specify theta values?
          user.delta.idx <- which(lavpartable$op == "~*~" &
            lavpartable$lhs == lavpartable$rhs &
            lavpartable$lhs %in% unlist(attr(lavpartable, "vnames")$ov.ord) &
            lavpartable$user == 1L)
          if (length(user.delta.idx)) {
            lav_msg_warn(
              gettextf("scaling (~*~) values for categorical variables
                       are ignored if parameterization = %s!",
                       "'theta'")
            )
          }
        }
      }

    # same for composites: call lav_model_set_parameters once to set
    # total/residual variances of composites in PSI
    } else if (lavmodel@composites) {
      lavmodel <- lav_model_set_parameters(
        lavmodel = lavmodel,
        x = lav_model_get_parameters(lavmodel)
      )
      # re-adjust parameter table
      lavpartable$start <- lav_model_get_parameters(lavmodel, type = "user")
    }
    if (lav_verbose()) {
      cat(" done.\n")
    }
  }

  # if parameterization = "delta" and categorical/correlation: check if
  # we have an observed mediator (new in 0.6-19)
  # but fixed (for recursive models) in 0.6-20
#   check.flag <- FALSE
#   if (!is.null(lavoptions$check.delta.cat.mediator) && # lavaan >= 0.6.19
#       lavoptions$check.delta.cat.mediator) {
#     check.flag <- TRUE
#   }
#   if (check.flag &&
#       (lavmodel@categorical || lavmodel@correlation) &&
#       lavmodel@representation == "LISREL" &&
#       lavmodel@parameterization == "delta") {
#     # get idx BETA matrices
# 	beta.idx   <- which(names(lavmodel@GLIST) == "beta")
# 	# for every block
# 	for (i in seq_len(length(beta.idx))) {
# 	  this.beta <- abs(lavmodel@GLIST[[beta.idx[i]]])
#       this.beta[lavmodel@m.free.idx[[beta.idx[i]]]] <- 1.0
# 	  # exogenous variables:       have zero rows
# 	  # endogenous variables:      have non-zero rows
# 	  # endogenous-only variables: have non-zero rows and zero columns
# 	  # mediators:                 have non-zero rows and non-zero columns
# 	  m.idx <- which(apply(this.beta, 1, sum) != 0 &
#                      apply(this.beta, 2, sum) != 0)
# 	  if (length(m.idx) > 0L) {
# 	    # we have (at least) one mediator
# 	    # is one of them an observed variable? -> warn
#         m.names <- lavmodel@dimNames[[beta.idx[i]]][[1]][m.idx]
# 		ov.names   <- unlist(lavdata@ov.names)
#         ov.ordered <- unlist(lavdata@ordered)
#         # correlation model
# 		if (lavmodel@correlation && any(m.names %in% ov.names)) {
# 		  bad.names <- m.names[m.names %in% ov.names]
# 		  if (length(beta.idx) == 1L) {
#             lav_msg_warn(gettextf("model contains at least one observed mediator: [%s]; consider switching to parameterization = \"theta\"",
#             paste(bad.names, collapse = " ")))
# 		  } else {
#             lav_msg_warn(gettextf("model contains at least one observed mediator in block %i: [%s]; consider switching to parameterization = \"theta\"", i,
#             paste(bad.names, collapse = " ")))
# 		  }
#         # categorical mode
# 		} else if (lavmodel@categorical && any(m.names %in% ov.ordered)) {
#           bad.names <- m.names[m.names %in% ov.ordered]
#           if (length(beta.idx) == 1L) {
#             lav_msg_warn(gettextf("model contains at least one observed categorical mediator: [%s]; consider switching to parameterization = \"theta\"",
#             paste(bad.names, collapse = " ")))
#           } else {
#             lav_msg_warn(gettextf("model contains at least one observed categorical mediator in block %i: [%s]; consider switching to parameterization = \"theta\"", i,
#             paste(bad.names, collapse = " ")))
#           }
#         }
# 	  } # mediators
# 	} # block
#   } # delta parameterization

  list(
    lavpartable = lavpartable,
    lavmodel    = lavmodel
  )
}


lav_samplestats_icov <- function(COV = NULL, ridge = 0.0, x.idx = integer(0L),
                                 ngroups = 1L, g = 1L) {

  cS <- tryCatch(chol(COV), error = function(e) NULL)

  # what if this fails...
  # ridge exogenous part only (if any); this may help for GLS (but not ML)
  if (is.null(cS)) {
    if (length(x.idx) > 0L && ridge > 0) {
      # maybe, we can fix it by gently ridging the exo variances
      ridge.eps <- ridge
      diag(COV)[x.idx] <- diag(COV)[x.idx] + ridge.eps

      # try again
      cS <- tryCatch(chol(COV), error = function(e) NULL)

      if (is.null(cS)) {
        # fatal stop after all
        lav_msg_stop(gettext(
          "sample covariance matrix is not positive-definite"))
      } else {
        cov <- chol2inv(cS)
        d <- diag(cS)
        cov.log.det <- 2 * sum(log(d))
        # give a warning
        if (ngroups > 1) {
          lav_msg_warn(gettextf(
            "sample covariance matrix in group: %s is not
            positive-definite", g))
        } else {
          lav_msg_warn(gettext(
            "sample covariance matrix is not positive-definite"))
        }
      }
    } else {
      # fatal stop
      lav_msg_stop(gettext("sample covariance matrix is not positive-definite"))
    }
  } else {
    icov <- chol2inv(cS)
    d <- diag(cS)
    cov.log.det <- 2 * sum(log(d))
  }

  list(icov = icov, cov.log.det = cov.log.det)
}

lav_samplestats_step2 <- function(UNI = NULL,
                                  wt = NULL,
                                  ov.names = NULL, # error message only
                                  # polychoric and empty cells
                                  zero.add = c(0.5, 0.0),
                                  zero.keep.margins = TRUE,
                                  zero.cell.warn = FALSE,
                                  # keep track of tables with zero cells?
                                  zero.cell.tables = TRUE) {
  nvar <- length(UNI)
  COR <- diag(nvar)

  if (zero.cell.tables) {
    zero.var1 <- character(0L)
    zero.var2 <- character(0L)
  }

  # one-by-one (for now)
  for (j in seq_len(nvar - 1L)) {
    for (i in (j + 1L):nvar) {
      if (is.null(UNI[[i]]$th.idx) &&
        is.null(UNI[[j]]$th.idx)) {
        rho <- lav_bvreg_cor_twostep_fit(
          fit.y1 = UNI[[i]], # linear
          fit.y2 = UNI[[j]], # linear
          wt = wt,
          Y1.name = ov.names[i],
          Y2.name = ov.names[j]
        )
        COR[i, j] <- COR[j, i] <- rho
      } else if (is.null(UNI[[i]]$th.idx) &&
        !is.null(UNI[[j]]$th.idx)) {
        # polyserial
        rho <- lav_bvmix_cor_twostep_fit(
          fit.y1 = UNI[[i]], # linear
          fit.y2 = UNI[[j]], # ordinal
          wt = wt,
          Y1.name = ov.names[i],
          Y2.name = ov.names[j]
        )
        COR[i, j] <- COR[j, i] <- rho
      } else if (is.null(UNI[[j]]$th.idx) &&
        !is.null(UNI[[i]]$th.idx)) {
        # polyserial
        rho <- lav_bvmix_cor_twostep_fit(
          fit.y1 = UNI[[j]], # linear
          fit.y2 = UNI[[i]], # ordinal
          wt = wt,
          Y1.name = ov.names[j],
          Y2.name = ov.names[i]
        )
        COR[i, j] <- COR[j, i] <- rho
      } else if (!is.null(UNI[[i]]$th.idx) &&
        !is.null(UNI[[j]]$th.idx)) {
        # polychoric correlation
        rho <- lav_bvord_cor_twostep_fit(
          fit.y1 = UNI[[j]], # ordinal
          fit.y2 = UNI[[i]], # ordinal
          wt = wt,
          zero.add = zero.add,
          zero.keep.margins = zero.keep.margins,
          zero.cell.warn = zero.cell.warn,
          zero.cell.flag = zero.cell.tables,
          Y1.name = ov.names[i],
          Y2.name = ov.names[j]
        )
        if (zero.cell.tables) {
          if (attr(rho, "zero.cell.flag")) {
            zero.var1 <- c(zero.var1, ov.names[j])
            zero.var2 <- c(zero.var2, ov.names[i])
          }
          attr(rho, "zero.cell.flag") <- NULL
        }
        COR[i, j] <- COR[j, i] <- rho
      }
      # check for near 1.0 correlations
      if (abs(COR[i, j]) > 0.99) {
        lav_msg_warn(gettextf(
          "correlation between variables %1$s and %2$s is (nearly) 1.0",
          ov.names[i], ov.names[j]))
      }
    }
  }

  # keep track of tables with zero cells
  if (zero.cell.tables) {
    zero.cell.tables <- cbind(zero.var1, zero.var2)
    attr(COR, "zero.cell.tables") <- zero.cell.tables
  }

  COR
}

# check if a fitted model is admissible
lav_object_post_check <- function(object) {
  stopifnot(inherits(object, "lavaan"))
  lavpartable <- object@ParTable
  lavmodel <- object@Model
  lavdata <- object@Data

  var.ov.ok <- var.lv.ok <- result.ok <- TRUE

  # 1a. check for negative variances ov
  var.idx <- which(lavpartable$op == "~~" &
    lavpartable$lhs %in% lav_object_vnames(object, "ov") &
    lavpartable$lhs == lavpartable$rhs)
  if (length(var.idx) > 0L && any(lavpartable$est[var.idx] < 0.0)) {
    result.ok <- var.ov.ok <- FALSE
    lav_msg_warn(gettext("some estimated ov variances are negative"))
  }

  # 1b. check for negative variances lv
  var.idx <- which(lavpartable$op == "~~" &
    lavpartable$lhs %in% lav_object_vnames(object, "lv") &
    lavpartable$lhs == lavpartable$rhs)
  if (length(var.idx) > 0L && any(lavpartable$est[var.idx] < 0.0)) {
    result.ok <- var.lv.ok <- FALSE
    lav_msg_warn(gettext("some estimated lv variances are negative"))
  }

  # 2. is cov.lv (PSI) positive definite? (only if we did not already warn
  # for negative variances)
  if (var.lv.ok && length(lav_object_vnames(lavpartable, type = "lv.regular")) > 0L) {
    ETA <- lavTech(object, "cov.lv")
    for (g in 1:lavdata@ngroups) {
      if (nrow(ETA[[g]]) == 0L) next
      txt.group <- if (lavdata@ngroups > 1L) gettextf("in group %s", g) else ""
      eigvals <- eigen(ETA[[g]], symmetric = TRUE, only.values = TRUE)$values
      if (any(eigvals < -1 * .Machine$double.eps^(3 / 4))) {
        lav_msg_warn(gettextf(
          "covariance matrix of latent variables is not positive definite %s;
          use lavInspect(fit, \"cov.lv\") to investigate.", txt.group
        ))
        result.ok <- FALSE
      }
    }
  }

  # 3. is THETA positive definite (but only for numeric variables)
  # and if we not already warned for negative ov variances
  if (var.ov.ok) {
    THETA <- lavTech(object, "theta")
    for (g in 1:lavdata@ngroups) {
      num.idx <- lavmodel@num.idx[[g]]
      if (length(num.idx) > 0L) {
        txt.group <- if (lavdata@ngroups > 1L) gettextf("in group %s", g) else ""
        eigvals <- eigen(THETA[[g]][num.idx, num.idx, drop = FALSE],
          symmetric = TRUE,
          only.values = TRUE
        )$values
        if (any(eigvals < -1 * .Machine$double.eps^(3 / 4))) {
          lav_msg_warn(gettextf(
            "the covariance matrix of the residuals of the observed variables
            (theta) is not positive definite %s; use lavInspect(fit, \"theta\")
            to investigate.", txt.group))
          result.ok <- FALSE
        }
      }
    }
  }

  result.ok
}

# functions related to GFI and other 'absolute' fit indices

# lower-level functions:
# - lav_fit_gfi
# - lav_fit_agfi
# - lav_fit_pgfi

# higher-level functions:
# - lav_fit_gfi_lavobject

# Y.R. 21 July 2022

# original formulas were given in Joreskog and Sorbom (1984) user's guide
# for LISREL VI (one for ML, and another for ULS)

# here we use the more 'general' formulas
# (generalized to allow for meanstructures etc)

# References:

# Mulaik, S. A., James, L. R., Van Alstine, J., Bennett, N., Lind, S., &
# Stilwell, C. D. (1989). Evaluation of goodness-of-fit indices for structural
# equation models. Psychological bulletin, 105(3), 430.

# Tanaka, J. S., & Huba, G. J. (1985). A fit index for covariance structure
# models under arbitrary GLS estimation. British Journal of Mathematical and
# Statistical Psychology, 38,197-201.

lav_fit_gfi <- function(WLS.obs = NULL, WLS.est = NULL, WLS.V = NULL,
                        NOBS = NULL) {
  # number of groups
  G <- length(WLS.obs)

  # compute gfi per group
  gfi.group <- numeric(G)
  for (g in 1:G) {
    wls.obs <- WLS.obs[[g]]
    wls.est <- WLS.est[[g]]
    wls.v <- WLS.V[[g]]

    if (is.null(wls.v)) {
      gfi.group[g] <- as.numeric(NA)
    } else {
      wls.diff <- wls.obs - wls.est
      if (is.matrix(wls.v)) {
        # full weight matrix
        t1 <- crossprod(wls.diff, wls.v) %*% wls.diff
        t2 <- crossprod(wls.obs, wls.v) %*% wls.obs
      } else {
        # diagonal weight matrix
        t1 <- as.numeric(crossprod(wls.diff^2, wls.v))
        t2 <- as.numeric(crossprod(wls.obs^2, wls.v))
      }
      gfi.group[g] <- 1 - t1 / t2
    }
  }

  if (G > 1) {
    ## CHECKME: get the scaling right
    NOBS <- unlist(NOBS)
    GFI <- as.numeric((NOBS %*% gfi.group) / sum(NOBS))
  } else {
    GFI <- gfi.group[1L]
  }

  GFI
}

# 'adjusted' GFI (adjusted for degrees of freedom)
lav_fit_agfi <- function(GFI = NULL, nel = NULL, df = NULL) {
  if (!is.finite(GFI) || !is.finite(nel) || !is.finite(df)) {
    AGFI <- as.numeric(NA)
  } else if (df > 0) {
    AGFI <- 1 - (nel / df) * (1 - GFI)
  } else {
    AGFI <- 1
  }

  AGFI
}

# PGFI: parsimony goodness-of-fit index

# Mulaik, S. A., James, L. R., Van Alstine, J., Bennett, N., Lind, S., &
# Stilwell, C. D. (1989). Evaluation of goodness-of-fit indices for structural
# equation models. Psychological bulletin, 105(3), 430.

# LISREL formula (Simplis book 2002, p. 126)
lav_fit_pgfi <- function(GFI = NULL, nel = NULL, df = NULL) {
  if (!is.finite(GFI) || !is.finite(nel) || !is.finite(df)) {
    PGFI <- as.numeric(NA)
  } else if (nel == 0) {
    PGFI <- as.numeric(NA)
  } else {
    PGFI <- (df / nel) * GFI
  }

  PGFI
}


lav_fit_gfi_lavobject <- function(lavobject = NULL, fit.measures = "gfi") {
  # check lavobject
  stopifnot(inherits(lavobject, "lavaan"))

  # possible fit measures
  fit.gfi <- c("gfi", "agfi", "pgfi")

  # which one do we need?
  if (missing(fit.measures)) {
    # default set
    fit.measures <- fit.gfi
  } else {
    # remove any not-GFI related index from fit.measures
    rm.idx <- which(!fit.measures %in% fit.gfi)
    if (length(rm.idx) > 0L) {
      fit.measures <- fit.measures[-rm.idx]
    }
    if (length(fit.measures) == 0L) {
      return(list())
    }
  }

  # extract ingredients
  WLS.obs <- lav_object_inspect_wls_obs(lavobject)
  WLS.est <- lav_object_inspect_wls_est(lavobject)
  WLS.V <- lav_object_inspect_wls_v(lavobject)
  NOBS <- lavobject@SampleStats@nobs

  # compute GFI
  GFI <- lav_fit_gfi(
    WLS.obs = WLS.obs, WLS.est = WLS.est,
    WLS.V = WLS.V, NOBS = NOBS
  )

  # total number of modeled sample stats
  nel <- length(unlist(WLS.obs))

  # degrees of freedom
  df <- lavobject@test[[1]]$df

  # container
  indices <- list()

  indices["gfi"] <- GFI
  indices["agfi"] <- lav_fit_agfi(GFI = GFI, nel = nel, df = df)
  indices["pgfi"] <- lav_fit_pgfi(GFI = GFI, nel = nel, df = df)

  # return only those that were requested
  indices[fit.measures]
}

# 'robust' mean and (co)variance matrix using Huber weights
#
# see Yuan & Hayashi (2010). Fitting Data to Model: SEM Diagnosis using two
#     scatter plots. Psychological Methods, 15(4), 335-351
#
# this function is based on the 'robmusig' function from K.H. Yuan's website:
# https://www.nd.edu/~kyuan/SEMdiagnosis
# see file CFA.r lines 46--96
#
lav_cov_huber <- function(Y = NULL, prob = 0.95, max.it = 200L, tol = 1e-07) {
  Y <- as.matrix(Y)
  NAMES <- colnames(Y)
  Y <- unname(Y)
  N <- nrow(Y)
  P <- ncol(Y)

  # tuning parameters for Huber's weight
  chip <- qchisq(prob, P)
  ck <- sqrt(chip)
  cbeta <- (P * pchisq(chip, P + 2L) + chip * (1 - prob)) / P

  # initial values
  this.mu <- colMeans(Y, na.rm = TRUE)
  this.sigma <- cov(Y, use = "pairwise.complete.obs")

  for (i in seq_len(max.it)) {
    # store old
    old.mu <- this.mu
    old.sigma <- this.sigma

    # squared Mahalanobis distance
    inv.sigma <- solve(this.sigma)
    Y.c <- t(t(Y) - this.mu)
    mdist2 <- rowSums((Y.c %*% inv.sigma) * Y.c)
    mdist <- sqrt(mdist2)

    # Huber weights
    wt <- ifelse(mdist <= ck, 1, ck / mdist)

    # weighted mean
    this.mu <- apply(Y, 2L, weighted.mean, w = wt, na.rm = TRUE)

    # weighted cov
    Y.c <- t(t(Y) - this.mu)
    this.sigma <- crossprod(Y.c * wt) / (N * cbeta)
    # question: why N, and not sum(wt)?

    # check progress
    diff.mu <- abs(this.mu - old.mu)
    diff.sigma <- abs(this.sigma - old.sigma)
    crit <- max(c(max(diff.mu), max(diff.sigma)))
    if (crit < tol) {
      break
    }
    if (i == max.it) {
      lav_msg_warn(gettext(
        "maximum number of iterations has been reached, without convergence."))
    }
  }

  names(this.mu) <- NAMES
  colnames(this.sigma) <- rownames(this.sigma) <- NAMES

  res <- list(Mu = this.mu, Sigma = this.sigma, niter = i, wt = wt)

  res
}

# YR 18 Dec 2015
# - functions to (directly) compute the inverse of 'Gamma' (the asymptotic
#   variance matrix of the sample statistics)
# - often used as 'WLS.V' (the weight matrix in WLS estimation)
#   and when computing the expected information matrix

# NOTE:
#  - three types:
#       1) plain         (conditional.x = FALSE, fixed.x = FALSE)
#       2) fixed.x       (conditional.x = FALSE, fixed.x = TRUE)
#       3) conditional.x (conditional.x = TRUE)
#  - if conditional.x = TRUE, we ignore fixed.x (can be TRUE or FALSE)

# NORMAL-THEORY
lav_samplestats_Gamma_inverse_NT <- function(Y = NULL,
                                             COV = NULL,
                                             ICOV = NULL,
                                             MEAN = NULL,
                                             rescale = TRUE,
                                             x.idx = integer(0L),
                                             fixed.x = FALSE,
                                             conditional.x = FALSE,
                                             meanstructure = FALSE,
                                             slopestructure = FALSE) {
  # check arguments
  if (length(x.idx) == 0L) {
    conditional.x <- FALSE
    fixed.x <- FALSE
  }

  if (is.null(ICOV)) {
    if (is.null(COV)) {
      stopifnot(!is.null(Y))

      # coerce to matrix
      Y <- unname(as.matrix(Y))
      N <- nrow(Y)
      COV <- cov(Y)
      if (rescale) {
        COV <- COV * (N - 1) / N # ML version
      }
    }

    ICOV <- solve(COV)
  }

  # if conditional.x, we may also need COV and MEAN
  if (conditional.x && length(x.idx) > 0L &&
    (meanstructure || slopestructure)) {
    if (is.null(COV)) {
      stopifnot(!is.null(Y))

      # coerce to matrix
      Y <- unname(as.matrix(Y))
      N <- nrow(Y)
      COV <- cov(Y)

      if (rescale) {
        COV <- COV * (N - 1) / N # ML version
      }
    }

    if (is.null(MEAN)) {
      stopifnot(!is.null(Y))
      MEAN <- unname(colMeans(Y))
    }
  }

  # rename
  S.inv <- ICOV
  S <- COV
  M <- MEAN

  # unconditional
  if (!conditional.x) {
    # unconditional - stochastic x
    if (!fixed.x) {
      # if (lav_use_lavaanC()) {
      #   Gamma.inv <- lavaanC::m_kronecker_dup_pre_post(S.inv, multiplicator = 0.5)
      # } else {
        Gamma.inv <- 0.5 * lav_matrix_duplication_pre_post(S.inv %x% S.inv)
      # }
      if (meanstructure) {
        Gamma.inv <- lav_matrix_bdiag(S.inv, Gamma.inv)
      }

      # unconditional - fixed x
    } else {
      # handle fixed.x = TRUE
      # if (lav_use_lavaanC()) {
      #   Gamma.inv <- lavaanC::m_kronecker_dup_pre_post(S.inv, multiplicator = 0.5)
      # } else {
        Gamma.inv <- 0.5 * lav_matrix_duplication_pre_post(S.inv %x% S.inv)
      # }

      # zero rows/cols corresponding with x/x combinations
      nvar <- NROW(ICOV)
      pstar <- nvar * (nvar + 1) / 2
      M <- matrix(0, nvar, nvar)
      M[lav_matrix_vech_idx(nvar)] <- seq_len(pstar)
      zero.idx <- lav_matrix_vech(M[x.idx, x.idx, drop = FALSE])
      Gamma.inv[zero.idx, ] <- 0
      Gamma.inv[, zero.idx] <- 0

      if (meanstructure) {
        S.inv.nox <- S.inv
        S.inv.nox[x.idx, ] <- 0
        S.inv.nox[, x.idx] <- 0
        Gamma.inv <- lav_matrix_bdiag(S.inv.nox, Gamma.inv)
      }
    }
  } else {
    # conditional.x

    # 4 possibilities:
    # - no meanstructure, no slopes
    # -    meanstructure, no slopes
    # - no meanstructure, slopes
    # -    meanstructure, slopes

    S11 <- S.inv[-x.idx, -x.idx, drop = FALSE]

    # if (lav_use_lavaanC()) {
    #   Gamma.inv <- lavaanC::m_kronecker_dup_pre_post(S11, multiplicator = 0.5)
    # } else {
      Gamma.inv <- 0.5 * lav_matrix_duplication_pre_post(S11 %x% S11)
    # }

    if (meanstructure || slopestructure) {
      C <- S[x.idx, x.idx, drop = FALSE]
      MY <- M[-x.idx]
      MX <- M[x.idx]
      C3 <- rbind(
        c(1, MX),
        cbind(MX, C + tcrossprod(MX))
      )
    }

    if (meanstructure) {
      if (slopestructure) {
        A11 <- C3 %x% S11
      } else {
        c11 <- 1 / solve(C3)[1, 1, drop = FALSE]
        A11 <- c11 %x% S11
      }
    } else {
      if (slopestructure) {
        A11 <- C %x% S11
      } else {
        A11 <- matrix(0, 0, 0)
      }
    }

    if (meanstructure || slopestructure) {
      Gamma.inv <- lav_matrix_bdiag(A11, Gamma.inv)
    }
  }

  Gamma.inv
}

# numeric approximation of the Hessian
# using an analytic gradient
lav_model_hessian <- function(lavmodel = NULL,
                              lavsamplestats = NULL,
                              lavdata = NULL,
                              lavoptions = NULL,
                              lavcache = NULL,
                              group.weight = TRUE,
                              ceq.simple = FALSE,
                              h = 1e-06) {
  estimator <- lavmodel@estimator

  # catch numerical gradient
  if (lavoptions$optim.gradient == "numerical") {
    obj.f <- function(x) {
      lavmodel2 <- lav_model_set_parameters(lavmodel, x = x)
      lav_model_objective(
        lavmodel = lavmodel2,
        lavsamplestats = lavsamplestats, lavdata = lavdata,
        lavcache = lavcache
      )[1]
    }
    x <- lav_model_get_parameters(lavmodel = lavmodel)
    Hessian <- numDeriv::hessian(func = obj.f, x = x)
    return(Hessian)
  }

  # computing the Richardson extrapolation
  if (!ceq.simple && lavmodel@ceq.simple.only) {
    npar <- lavmodel@nx.unco
    type.glist <- "unco"
  } else {
    npar <- lavmodel@nx.free
    type.glist <- "free"
  }
  Hessian <- matrix(0, npar, npar)
  x <- lav_model_get_parameters(lavmodel = lavmodel)
  if (!ceq.simple && lavmodel@ceq.simple.only) {
    # unpack
    x <- drop(x %*% t(lavmodel@ceq.simple.K))
  }
  for (j in seq_len(npar)) {
    # FIXME: the number below should vary as a function of 'x[j]'
    h.j <- h
    x.left <- x.left2 <- x.right <- x.right2 <- x
    x.left[j] <- x[j] - h.j
    x.left2[j] <- x[j] - 2 * h.j
    x.right[j] <- x[j] + h.j
    x.right2[j] <- x[j] + 2 * h.j

    g.left <-
      lav_model_gradient(
        lavmodel = lavmodel,
        GLIST = lav_model_x2glist(
          lavmodel =
            lavmodel, type = type.glist,
          x.left
        ),
        lavsamplestats = lavsamplestats,
        lavdata = lavdata,
        lavcache = lavcache,
        type = "free",
        group.weight = group.weight,
        ceq.simple = ceq.simple
      )
    g.left2 <-
      lav_model_gradient(
        lavmodel = lavmodel,
        GLIST = lav_model_x2glist(
          lavmodel =
            lavmodel, type = type.glist,
          x.left2
        ),
        lavsamplestats = lavsamplestats,
        lavdata = lavdata,
        lavcache = lavcache,
        type = "free",
        group.weight = group.weight,
        ceq.simple = ceq.simple
      )

    g.right <-
      lav_model_gradient(
        lavmodel = lavmodel,
        GLIST = lav_model_x2glist(
          lavmodel =
            lavmodel, type = type.glist,
          x.right
        ),
        lavsamplestats = lavsamplestats,
        lavdata = lavdata,
        lavcache = lavcache,
        type = "free",
        group.weight = group.weight,
        ceq.simple = ceq.simple
      )

    g.right2 <-
      lav_model_gradient(
        lavmodel = lavmodel,
        GLIST = lav_model_x2glist(
          lavmodel =
            lavmodel, type = type.glist,
          x.right2
        ),
        lavsamplestats = lavsamplestats,
        lavdata = lavdata,
        lavcache = lavcache,
        type = "free",
        group.weight = group.weight,
        ceq.simple = ceq.simple
      )

    Hessian[, j] <- (g.left2 - 8 * g.left + 8 * g.right - g.right2) / (12 * h.j)
  }

  # check if Hessian is (almost) symmetric, as it should be
  max.diff <- max(abs(Hessian - t(Hessian)))
  if (max.diff > 1e-05 * max(diag(Hessian))) {
    # hm, Hessian is not symmetric -> WARNING!
    lav_msg_warn(gettextf(
    "Hessian is not fully symmetric. Max diff = %1$s (Max diag Hessian = %2$s)",
    max.diff, max(diag(Hessian))))
    # FIXME: use numDeriv::hessian instead?
  }
  Hessian <- (Hessian + t(Hessian)) / 2.0

  Hessian
}

# if only chol would accept a complex matrix...
lav_model_hessian_complex <- function(lavmodel = NULL,
                                      lavsamplestats = NULL,
                                      lavdata = NULL,
                                      lavcache = NULL,
                                      group.weight = TRUE) {
  gradf <- function(x) {
    GLIST <- lav_model_x2glist(lavmodel = lavmodel, x = x)
    dx <- lav_model_gradient(
      lavmodel = lavmodel,
      GLIST = GLIST,
      lavsamplestats = lavsamplestats,
      lavdata = lavdata,
      lavcache = lavcache,
      type = "free",
      group.weight = group.weight
    )
    dx
  }

  x <- lav_model_get_parameters(lavmodel = lavmodel)
  Hessian <- lav_func_jacobian_complex(func = gradf, x = x)

  Hessian
}

# casewise residuals

lav_residuals_casewise <- function(object, labels = labels) {

  # check object
  object <- lav_object_check_version(object)

  # check if we have full data
  if (object@Data@data.type != "full") {
    lav_msg_stop(gettext("casewise residuals not available if sample statistics
                         were used for fitting the model"))
  }
  # check if we have categorical data
  if (object@Model@categorical) {
    lav_msg_stop(gettext(
      "casewise residuals not available if data is categorical"))
  }

  G <- object@Data@ngroups
  ov.names <- object@Data@ov.names

  X <- object@Data@X
  if (object@Model@categorical) {
    # add 'eXo' columns to X
    X <- lapply(seq_len(object@Data@ngroups), function(g) {
      ret <- cbind(X[[g]], object@Data@eXo[[g]])
      ret
    })
  }
  M <- lav_predict_yhat(object)
  # Note: if M has already class lavaan.matrix, print goes crazy
  # with Error: C stack usage is too close to the limit
  OUT <- lapply(seq_len(G), function(x) {
    out <- X[[x]] - M[[x]]
    class(out) <- c("lavaan.matrix", "matrix")
    out
  })

  if (labels) {
    for (g in 1:G) {
      colnames(OUT[[g]]) <- object@pta$vnames$ov[[g]]
    }
  }

  if (G == 1) {
    OUT <- OUT[[1]]
  } else {
    names(OUT) <- unlist(object@Data@group.label)
  }

  OUT
}

# store pta in attributes of partable
lav_partable_set_cache <- function(partable, pta = NULL, force = FALSE) {
  if (!force &&
      !is.null(attr(partable, "vnames")) &&
      !is.null(attr(partable, "nvar"))) {
        return(partable)                    # cache already OK
    }
  if (is.null(pta)) {
    if (force) attr(partable, "vnames") <- NULL
    pta <- lav_partable_attributes(partable)
  }

  for (n in names(pta)) {
    attr(partable, n) <- pta[[n]]
  }

  partable
}

lav_partable_remove_cache <- function(partable) {
  attributelist <- names(attributes(partable))

  for (n in attributelist) {
    if (n != "ovda" && n != "names") attr(partable, n) <- NULL
  }

  partable
}

# lavMultipleImputation: fit the *same* model, on a set of imputed datasets
# YR - 11 July 2016

lavMultipleImputation <-
  function(model = NULL,
           dataList = NULL,
           ndat = length(dataList),
           cmd = "sem",
           ...,
           store.slots = c("partable"),
           FUN = NULL,
           show.progress = FALSE,
           parallel = c("no", "multicore", "snow"),
           ncpus = max(1L, parallel::detectCores() - 1L),
           cl = NULL) {
    # dotdotdot
    dotdotdot <- list()

    # fit multiple times
    fit <- do.call("lavaanList", args = c(list(
      model = model,
      dataList = dataList, ndat = ndat, cmd = cmd,
      store.slots = store.slots, FUN = FUN,
      show.progress = show.progress,
      parallel = parallel, ncpus = ncpus, cl = cl
    ), dotdotdot))

    # flag multiple imputation
    fit@meta$lavMultipleImputation <- TRUE

    fit
  }

# read in information from Mplus difftest output, return as list
#
# line 1: test statistic (unscaled)
# line 2: number of groups
# line 3: number of sample statistics (ndat)
# line 4: number of free parameters (npar)
# delta (ndat x npar)
# P1 (E.inv) lav_matrix_vechr(npar x npar)
# V1 (NVarCov) lav_matrix_vechr(npar x npar)
lavutils_mplus_readdifftest <- function(file = "deriv.dat") {
  ### FIXME: does not work for multiple groups yet!!!

  raw <- scan(file, quiet = TRUE)
  T1 <- raw[1] # function value (usually T1 * 2 * nobs to get X2)
  ngroups <- as.integer(raw[2])
  ndat <- as.integer(raw[3])
  npar <- as.integer(raw[4])
  pstar <- npar * (npar + 1) / 2

  # delta
  offset <- 4L
  delta_raw <- raw[offset + seq_len(npar * ndat)]
  Delta <- matrix(delta_raw, nrow = ndat, ncol = npar, byrow = TRUE)

  # P1
  offset <- 4L + npar * ndat
  p1_raw <- raw[offset + seq_len(pstar)]
  P1 <- lav_matrix_lower2full(p1_raw)

  # (robust) NACOV npar
  offset <- 4L + npar * ndat + pstar
  nacov_raw <- raw[offset + seq_len(pstar)]
  V1 <- lav_matrix_lower2full(nacov_raw)

  # just for fun, M1
  # M1 <- (P1 - P1 %*% H %*% solve(t(H) %*% P1 %*% H) %*% t(H) %*% P1) %*% V1

  list(
    T1 = T1, ngroups = ngroups, ndat = ndat, npar = npar, pstar = pstar,
    Delta = Delta, P1 = P1, V1 = V1
  )
}

# various fit measures

# - lav_fit_cn
# - lav_fit_wrmr
# - lav_fit_mfi
# - lav_fit_ecvi

# Y.R. 21 July 2022

# Hoelter Critical N (CN)
lav_fit_cn <- function(X2 = NULL, df = NULL, N = NULL, alpha = 0.05) {
  # catch df=0, X2=0
  if (df == 0 && X2 < sqrt(.Machine$double.eps)) { # added sqrt() in 0.6-21
    CN <- as.numeric(NA)
  } else {
    CN <- qchisq(p = (1 - alpha), df = df) / (X2 / N) + 1
  }

  CN
}

# WRMR
# we use the definition: wrmr = sqrt ( 2*N*F / nel )
# Note: when multiple groups, 'nel' only seems to correspond to the
# first group???
lav_fit_wrmr <- function(X2 = NULL, nel = NULL) {
  if (nel > 0) {
    WRMR <- sqrt(X2 / nel)
  } else {
    WRMR <- as.numeric(NA)
  }

  WRMR
}

# MFI - McDonald Fit Index (McDonald, 1989)
lav_fit_mfi <- function(X2 = NULL, df = NULL, N = NULL) {
  MFI <- exp(-0.5 * (X2 - df) / N)
  MFI
}

# ECVI - cross-validation index (Brown & Cudeck, 1989, eq 5)
# "In the special case where F = F_ML, Equation 5 [=ECVI] is the
# rescaled AIC employed by Cudeck and Browne (1983, Equation 5.1). This
# result is concordant with a finding of Stone (1977). He showed under general
# conditions that if the "leaving one out at a time" method of cross-validation
# (Stone, 1974; Geisser, 1975) is employed, a log-likelihood measure of
# predictive validity is asymptotically equivalent to the AIC." (p. 448)

# not defined for multiple groups and/or models with meanstructures
# TDJ: According to Dudgeon (2004, p. 317), "ECVI requires no adjustment
#      when a model is fitted simultaneously in multiple samples."
#      And I think the lack of mean structure in Brown & Cudeck (1989)
#      was a matter of habitual simplification back then, not necessity.
# YR: - why does Dudgeon eq 22 use (df + 2*npar) instead of (2*npar)??
lav_fit_ecvi <- function(X2 = NULL, npar = npar, N = N) {
  ECVI <- X2 / N + (2 * npar) / N
  ECVI
}

# in separate file LDW 06/04/2024

# rename names of se values, and check for invalid values
lav_options_check_se <- function(opt = NULL) {
  # unlike test=, se= should be a single character string
  if (length(opt$se) > 1L) opt$se <- opt$se[1]

  # backwards compatibility (0.4 -> 0.5)
  if (opt$se == "first.order") {
    opt$se <- "standard"
    opt$information[1] <- "first.order"
    if (length(opt$information) > 1L &&
        opt$information[2] == "default") {
      opt$information[2] <- "first.order"
    }
  } else if (opt$se == "observed") {
    opt$se <- "standard"
    opt$information[1] <- "observed"
    if (length(opt$information) > 1L &&
        opt$information[2] == "default") {
      opt$information[2] <- "observed"
    }
  } else if (opt$se == "expected") {
    opt$se <- "standard"
    opt$information[1] <- "expected"
    if (length(opt$information) > 1L &&
        opt$information[2] == "default") {
      opt$information[2] <- "expected"
    }
  }

  # handle generic 'robust' (except clustered/multilvel)
  # else if(opt$se == "robust" && !opt$.clustered && !opt$.multilevel) {
  #    if(opt$missing %in% c("ml", "ml.x")) {
  #        opt$se <- "robust.huber.white"
  #    } else if(opt$missing == "two.stage") {
  #        opt$se <- "two.stage"
  #    } else if(opt$missing == "robust.two.stage") {
  #        opt$se <- "robust.two.stage"
  #    } else {
  #        # depends on estimator!
  #        opt$se <- "robust.sem"
  #    }
  # }

  # GLS, NTRLS, FML, UMN
  ok.flag <- TRUE
  if (any(opt$estimator == c("gls", "ntrls", "fml"))) {
    ok.flag <- any(opt$se == c(
      "default", "none", "standard",
      "bootstrap", "external"
    ))
  }

  # WLS, DLS, DWLS, WLSM, WLSMV, WLSMVS, ULS, ULSM, ULSMV, ULSMVS
  else if (any(opt$estimator == c(
    "wls", "dls",
    "dwls", "wlsm", "wlsmv", "wlsmvs",
    "uls", "ulsm", "ulsmv", "ulsmvs"
  ))) {
    ok.flag <- any(opt$se == c(
      "default", "none", "standard",
      "bootstrap", "external",
      "robust", "robust.sem", "robust.sem.nt"
    ))
  }

  # PML
  else if (opt$estimator == "pml") {
    ok.flag <- any(opt$se == c(
      "default", "none", "standard",
      "bootstrap", "external",
      "robust.huber.white"
    ))
  }

  # FABIN, GUTTMAN1952, BENTLER1982, ...
  else if (any(opt$estimator == c(
    "fabin2", "fabin3", "mgm"))) {
    ok.flag <- any(opt$se == c("default", "none", "bootstrap", "external"))
  }

  # OTHERS
  else if (any(opt$estimator == c("fml", "mml", "reml"))) {
    ok.flag <- any(opt$se == c("default", "none", "standard", "external"))
  }

  if (!ok.flag) {
    lav_msg_stop(gettextf(
      "invalid value (%1$s) in se= argument for estimator %2$s.",
      opt$se, toupper(opt$estimator)))
  }

  opt
}

lav_lavaan_step13_vcov_boot <- function(lavoptions = NULL,
                                        lavmodel = NULL,
                                        lavsamplestats = NULL,
                                        lavdata = NULL,
                                        lavpartable = NULL,
                                        lavcache = NULL,
                                        lavimplied = NULL,
                                        lavh1 = NULL,
                                        x = NULL) {
  # # # # # # # # # # # # # # # #
  # #  13. lavvcov + lavboot # #
  # # # # # # # # # # # # # # # #

  # set VCOV to NULL
  # if lavoptions$se not "none", "external", "twostep" and
  #   lavmodel@nx.free > 0L and x converged or optim.method == "none"
  #   compute VCOV via lav_model_vcov
  # if attribute BOOT.COEFF of VCOV not NULL, store it in lavboot$coef
  # lavvcov <- list(se = lavoptions$se, information = lavoptions$information,
  #   vcov = VCOV1)
  #   where VCOV1 = VCOV without attributes (except dim) or ...
  #                 NULL if lavoptions$store.vcov FALSE or
  #                 store.vcov=="default" and rotation="none"
  # if lavoptions$se == "external"
  #   if lavpartable$se NULL
  #     lavpartable$se <- lav_model_vcov_se(..., VCOV=NULL, BOOT=NULL)
  #       + ** warning **
  # if lavpartable not "external" or "none" or "twostep"
  #     lavpartable$se <- lav_model_vcov_se(...)

  VCOV <- NULL # nolint
  if (lavoptions$se != "none" && lavoptions$se != "external" &&
    lavoptions$se != "twostep" &&
    (lavmodel@nefa == 0L ||
     (lavmodel@nefa > 0L && lavoptions$rotation == "none") ||
     (lavmodel@nefa > 0L && lavoptions$rotation.se == "delta")
    ) &&
    lavmodel@nx.free > 0L && (attr(x, "converged") ||
    lavoptions$optim.method == "none")) {
    if (lav_verbose()) {
      cat("computing VCOV for      se =", lavoptions$se, "...")
    }
    # special case: estimator = "IV"
    if (lavoptions$estimator %in% "IV" && !is.null(attr(x, "eqs"))) {
      VCOV <- lav_sem_miiv_vcov(
        lavmodel = lavmodel,
        lavsamplestats = lavsamplestats,
        lavoptions = lavoptions,
        lavpartable = lavpartable,
        lavimplied = lavimplied,
        lavh1 = lavh1,
        eqs = attr(x, "eqs")
      )
    } else {
      # everything else:
      VCOV <- lav_model_vcov( # nolint
        lavmodel = lavmodel,
        lavsamplestats = lavsamplestats,
        lavoptions = lavoptions,
        lavdata = lavdata,
        lavpartable = lavpartable,
        lavcache = lavcache,
        lavimplied = lavimplied,
        lavh1 = lavh1
      )
    }
    if (lav_verbose()) {
      cat(" done.\n")
    }
  } # VCOV

  # extract bootstrap results (if any)
  if (!is.null(attr(VCOV, "BOOT.COEF"))) {
    lavboot <- list()
    lavboot$coef <- attr(VCOV, "BOOT.COEF")
  } else {
    lavboot <- list()
  }

  # store VCOV in vcov
  # strip all attributes but 'dim'
  tmp.attr <- attributes(VCOV)
  VCOV1 <- VCOV # nolint
  attributes(VCOV1) <- tmp.attr["dim"] # nolint
  # store vcov? new in 0.6-6
  if (!is.null(lavoptions$store.vcov) && !is.null(VCOV1)) {
    if (is.logical(lavoptions$store.vcov) && !lavoptions$store.vcov) {
      VCOV1 <- NULL # nolint
    }
    if (is.character(lavoptions$store.vcov) &&
      lavoptions$rotation == "none" &&
      lavoptions$store.vcov == "default" &&
      ncol(VCOV1) > 200L) {
      VCOV1 <- NULL # nolint
    }
  }
  lavvcov <- list(
    se = lavoptions$se,
    information = lavoptions$information[1],
    vcov = VCOV1
  )

  # store se in partable
  if (lavoptions$se == "external") {
    if (is.null(lavpartable$se)) {
      lavpartable$se <- lav_model_vcov_se(
        lavmodel = lavmodel,
        lavpartable = lavpartable,
        VCOV = NULL, BOOT = NULL
      )
      lav_msg_warn(gettext(
        "se = \"external\" but parameter table does not contain a `se' column"))
    }
  } else if (lavoptions$se %in% c("none", "twostep")) {
    # do nothing
  } else {
    lavpartable$se <- lav_model_vcov_se(
      lavmodel = lavmodel,
      lavpartable = lavpartable,
      VCOV = VCOV,
      BOOT = lavboot$coef
    )
  }

  list(
    lavpartable = lavpartable,
    lavvcov     = lavvcov,
    VCOV        = VCOV,
    lavmodel    = lavmodel,
    lavboot     = lavboot
  )
}

# lavSimulate: fit the *same* model, on simulated datasets
# YR - 4 July 2016: initial version
# YR - 15 Oct 2024: add iseed (similar to lavBootstrap)
# YR - 26 Oct 2024: rm pop.model, add est.true argument

lavSimulate <- function(model = NULL, # user model
                        dataFunction = lav_data_simulate_old,
                        dataFunction.args = list(),
                        est.true = NULL,
                        ndat = 1000L,
                        cmd = "sem",
                        ...,
                        store.slots = c("partable"),
                        FUN = NULL,
                        show.progress = FALSE,
                        store.failed = FALSE,
                        parallel = c("no", "multicore", "snow"),
                        ncpus = max(1L, parallel::detectCores() - 1L),
                        cl = NULL,
                        iseed = NULL) {
  # dotdotdot
  dotdotdot <- list(...)

  # dotdotdot for fit.pop
  dotdotdot.pop <- dotdotdot
  dotdotdot.pop$verbose <- FALSE
  dotdotdot.pop$debug <- FALSE
  dotdotdot.pop$data <- NULL
  dotdotdot.pop$sample.cov <- NULL

  # 'fit' model without data, check 'true' parameters
  fit.pop <- do.call(cmd,
    args = c(list(model = model), dotdotdot.pop)
  )

  # check est.true= argument
  stopifnot(!missing(est.true), is.numeric(est.true),
            length(fit.pop@ParTable$lhs) == length(est.true))
  fit.pop@ParTable$est <- est.true
  fit.pop@ParTable$start <- est.true

  # per default, use 'true' values as starting values
  if (is.null(dotdotdot$start)) {
    dotdotdot$start <- fit.pop
  }

  # no warnings during/after the simulations
  # add 'warn = FALSE' to args

  # generate simulations
  fit <- do.call("lavaanList", args = c(list(
    model = model,
    dataFunction = dataFunction,
    dataFunction.args = dataFunction.args,
    ndat = ndat, cmd = cmd,
    store.slots = store.slots, FUN = FUN,
    show.progress = show.progress,
    store.failed = store.failed,
    parallel = parallel, ncpus = ncpus,
    cl = cl, iseed = iseed
  ), dotdotdot))

  # flag this is a simulation
  fit@meta$lavSimulate <- TRUE

  # store 'true' parameters in meta$est.true
  fit@meta$est.true <- est.true

  fit
}

lav_plot <- function(
  model = NULL,
  infile = NULL,
  varlv = FALSE,
  placenodes = NULL,
  edgelabelsbelow = NULL,
  group.covar.indicators = FALSE,
  common.opts = list(sloped.labels = TRUE,
                     mlovcolors = c("lightgreen", "lightblue"),
                     italic = TRUE,
                     lightness = 1,
                     auto.subscript = TRUE),
  rplot = list(outfile = "",
               addgrid = TRUE),
  tikz = list(outfile = "",
              cex = 1.3,
              standalone = FALSE),
  svg = list(outfile = "",
             stroke.width = 2L,
             font.size = 20L,
             idx.font.size = 15L,
             dy = 5L,
             font.family = "Latin Modern Math, arial, Aerial, sans",
             standalone = FALSE)
) {
  tmp <- lav_model_plotinfo(model,
                            infile = infile,
                            varlv = varlv)
  tmp <- lav_plotinfo_positions(tmp,
                            placenodes = placenodes,
                            edgelabelsbelow = edgelabelsbelow,
                            group.covar.indicators = group.covar.indicators)
  mc <- match.call()
  create_rplot <- !is.null(mc$rplot) || (is.null(mc$tikz) && is.null(mc$svg))
  if (create_rplot)
    do.call(lav_plotinfo_rgraph, c(list(plotinfo = tmp),
                                   common.opts,
                                   rplot))
  if (!is.null(mc$tikz))
    do.call(lav_plotinfo_tikzcode, c(list(plotinfo = tmp),
                             common.opts,
                             tikz))
  if (!is.null(mc$svg))
    do.call(lav_plotinfo_svgcode, c(list(plotinfo = tmp),
                             common.opts,
                             svg))
}

# takes a model in lavaan syntax and the user's data and returns the covariance
# matrix of observed variables.  Useful so that the user can do things like
# diagnose errors in the cov matrix, use cov2cor to look at the correlation
# matrix, try and invert the sample covariance matrix, etc.

# update 5/27/2011 JEB
# changelog: using sem and inspect to get output.
#            This way, all arguments such as groups, etc, can be used
# update 3 june 2011 YR: removed se="none" (since now implied by do.fit=FALSE)
# update 13 dec 2011 YR: changed name (to avoid confusion with the
#                        model-implied cov)
lavInspectSampleCov <- function(model, data, ...) {
  fit <- sem(model, data = data, ..., do.fit = FALSE)
  lavInspect(fit, "sampstat")
}

# lavMultipleGroups: fit the *same* model, on (typically a small number of)
#                    groups/sets
# YR - 11 July 2016

lavMultipleGroups <-
  function(model = NULL,
           dataList = NULL,
           ndat = length(dataList),
           cmd = "sem",
           ...,
           store.slots = c("partable"),
           FUN = NULL,
           show.progress = FALSE,
           parallel = c("no", "multicore", "snow"),
           ncpus = max(1L, parallel::detectCores() - 1L),
           cl = NULL) {
    # dotdotdot
    dotdotdot <- list()

    # fit multiple times
    fit <- do.call("lavaanList", args = c(list(
      model = model,
      dataList = dataList, ndat = ndat, cmd = cmd,
      store.slots = store.slots, FUN = FUN,
      show.progress = show.progress,
      parallel = parallel, ncpus = ncpus, cl = cl
    ), dotdotdot))

    # store group labels (if any)
    fit@meta$lavMultipleGroups <- TRUE
    fit@meta$group.label <- names(dataList)

    fit
  }

lav_lavaan_step07_bounds <- function(lavoptions = NULL,
                                     lavh1 = NULL,
                                     lavdata = NULL,
                                     lavsamplestats = NULL,
                                     lavpartable = NULL) {
  # # # # # # # # # # # # # # #
  # #  7. parameter bounds  # #
  # # # # # # # # # # # # # # #

  # if lavoptions$optim.bounds not NULL and its members lower and upper
  #   have length > 0L
  #   modify lavpartable via lav_partable_add_bounds

  # automatic bounds (new in 0.6-6)
  if (!is.null(lavoptions$optim.bounds) ||
    length(lavoptions$optim.bounds$lower) > 0L ||
    length(lavoptions$optim.bounds$upper) > 0L) {
    if (lav_verbose()) {
      cat("lavpartable bounds ...")
    }
    lavpartable <- lav_partable_add_bounds(
      partable = lavpartable,
      lavh1 = lavh1, lavdata = lavdata, lavsamplestats = lavsamplestats,
      lavoptions = lavoptions
    )
    if (lav_verbose()) {
      cat(" done.\n")
    }
  }

  lavpartable
}

1		# various ways to compute a (scaled) difference chi-square test statistic
2
3		# - 0.6-13: fix multiple-group UG^2 bug in Satorra.2000 (reported by
4		# Gronneberg, Foldnes and Moss) when Satterthwaite = TRUE and
5		# ngroups > 1L (use old.approach = TRUE to get the old result)
6
7		lav_test_diff_Satorra2000 <- function(m1, m0, H1 = TRUE, A.method = "delta",
8		A = NULL,
9		Satterthwaite = FALSE,
10		scaled.shifted = FALSE,
11		old.approach = FALSE) {
12	!	if (scaled.shifted) {
13	!	Satterthwaite <- TRUE
14		}
15
16		# extract information from m1 and m2
17	!	T1 <- m1@test[[1]]$stat
18	!	r1 <- m1@test[[1]]$df
19
20	!	T0 <- m0@test[[1]]$stat
21	!	r0 <- m0@test[[1]]$df
22
23		# m = difference between the df's
24	!	m <- r0 - r1
25
26		# check for identical df setting
27	!	if (m == 0L) {
28	!	return(list(
29	!	T.delta = (T0 - T1), scaling.factor = as.numeric(NA),
30	!	df.delta = m, a = as.numeric(NA), b = as.numeric(NA)
31		))
32		}
33
34		# check for (near) identical test statistics (despite m > 0)
35	!	if (abs(T1 - T0) < sqrt(.Machine$double.eps)) {
36	!	lav_msg_warn(gettext("the test statistic of the restriced model is (nearly)
37	!	identical to the test statistic of the full model;
38	!	check your models."))
39		}
40
41
42		# bail out here, if m == 0 (but we should catch this earlier)
43		# if(m < 1L) {
44		# txt <- paste("Can not compute (scaled) difference test when ",
45		# "the degrees of freedom (df) are the same for both ",
46		# "models:\n",
47		# "Df model 1 = ", r1, ", and Df model 2 = ", r0, "\n",
48		# sep = "")
49		# stop(lav_txt2message(txt, header = "lavaan ERROR:"))
50		# }
51
52	!	Gamma <- lavTech(m1, "Gamma") # the same for m1 and m0
53		# check for NULL
54	!	if (is.null(Gamma)) {
55	!	lav_msg_stop(gettext(
56	!	"can not compute Gamma matrix; perhaps missing = \"ml\"?"))
57		}
58
59	!	if (H1) {
60	!	WLS.V <- lavTech(m1, "WLS.V")
61	!	PI <- lav_model_delta(m1@Model)
62	!	P <- lavTech(m1, "information")
63		# needed? (yes, if H1 already has eq constraints)
64	!	P.inv <- lav_model_information_augment_invert(m1@Model,
65	!	information = P,
66	!	inverted = TRUE
67		)
68		# compute 'A' matrix
69		# NOTE: order of parameters may change between H1 and H0, so be
70		# careful!
71	!	if (is.null(A)) {
72	!	A <- lav_test_diff_A(m1, m0, method = A.method, reference = "H1")
73		# take into account equality constraints m1
74	!	if (A.method == "delta") {
75	!	if (m1@Model@eq.constraints) {
76	!	A <- A %*% t(m1@Model@eq.constraints.K)
77	!	} else if (m1@Model@ceq.simple.only) {
78	!	A <- A %*% t(m1@Model@ceq.simple.K)
79		}
80		}
81	!	if (lav_debug()) print(A)
82		}
83		} else {
84	!	lav_msg_stop(gettext("not ready yet"))
85
86	!	WLS.V <- lavTech(m0, "WLS.V")
87	!	PI <- lav_model_delta(m0@Model)
88	!	P <- lavTech(m0, "information")
89		# needed?
90	!	P.inv <- lav_model_information_augment_invert(m0@Model,
91	!	information = P,
92	!	inverted = TRUE
93		)
94
95		# compute 'A' matrix
96		# NOTE: order of parameters may change between H1 and H0, so be
97		# careful!
98	!	if (is.null(A)) {
99		# m1, m0 OR m0, m1 (works for delta, but not for exact)
100	!	A <- lav_test_diff_A(m1, m0, method = A.method, reference = "H0")
101		# take into account equality constraints m1
102	!	if (m0@Model@eq.constraints) {
103	!	A <- A %*% t(m0@Model@eq.constraints.K)
104	!	} else if (m0@Model@ceq.simple.only) {
105	!	A <- A %*% t(m0@Model@ceq.simple.K)
106		}
107	!	if (lav_debug()) print(A)
108		}
109		}
110
111		# compute tr UG per group
112	!	ngroups <- m1@SampleStats@ngroups
113	!	UG.group <- vector("list", length = ngroups)
114
115		# safety check: A %% P.inv %% t(A) should NOT contain all-zero
116		# rows/columns
117		# FIXME: is this really needed? As we use ginv later on
118	!	APA <- A %% P.inv %% t(A)
119	!	cSums <- colSums(APA)
120	!	rSums <- rowSums(APA)
121	!	empty.idx <- which(abs(cSums) < .Machine$double.eps^0.5 &
122	!	abs(rSums) < .Machine$double.eps^0.5)
123	!	if (length(empty.idx) > 0) {
124	!	A <- A[-empty.idx, , drop = FALSE]
125		}
126	!	if (nrow(A) == 0L) {
127		# oops... abort!
128	!	return(list(
129	!	T.delta = (T0 - T1), scaling.factor = as.numeric(NA),
130	!	df.delta = m, a = as.numeric(NA), b = as.numeric(NA)
131		))
132		}
133
134		# PAAPAAP
135	!	PAAPAAP <- P.inv %% t(A) %% MASS::ginv(A %% P.inv %% t(A)) %% A %% P.inv
136
137		# compute scaling factor
138	!	fg <- unlist(m1@SampleStats@nobs) / m1@SampleStats@ntotal
139
140
141		# this is what we did <0.6-13
142	!	if (old.approach) {
143	!	trace.UGamma <- numeric(ngroups)
144	!	trace.UGamma2 <- numeric(ngroups)
145	!	for (g in 1:ngroups) {
146	!	UG.group <- WLS.V[[g]] %% Gamma[[g]] %% WLS.V[[g]] %*%
147	!	PI[[g]] %% PAAPAAP %% t(PI[[g]])
148	!	trace.UGamma[g] <- sum(diag(UG.group))
149	!	if (Satterthwaite) {
150	!	trace.UGamma2[g] <- sum(diag(UG.group %*% UG.group))
151		}
152		}
153
154	!	trace.UGamma <- sum(fg * trace.UGamma)
155	!	if (Satterthwaite) {
156	!	trace.UGamma2 <- sum(fg * trace.UGamma2)
157		}
158		} else {
159		# for trace.UGamma, we can compute the trace per group
160		# as in Satorra (2000) eq. 23
161	!	trace.UGamma <- numeric(ngroups)
162	!	for (g in 1:ngroups) {
163	!	UG.group <- WLS.V[[g]] %% Gamma[[g]] %% WLS.V[[g]] %*%
164	!	PI[[g]] %% PAAPAAP %% t(PI[[g]])
165	!	trace.UGamma[g] <- sum(diag(UG.group))
166		}
167	!	trace.UGamma <- sum(fg * trace.UGamma)
168
169		# but for trace.UGamma2, we can no longer compute the trace per group
170	!	trace.UGamma2 <- as.numeric(NA)
171	!	if (Satterthwaite) {
172		# global approach (not group-specific)
173	!	Gamma.f <- Gamma
174	!	for (g in seq_along(Gamma)) {
175	!	Gamma.f[[g]] <- fg[g] * Gamma[[g]]
176		}
177	!	Gamma.all <- lav_matrix_bdiag(Gamma.f)
178	!	V.all <- lav_matrix_bdiag(WLS.V)
179	!	PI.all <- do.call(rbind, PI)
180	!	U.all <- V.all %% PI.all %% PAAPAAP %% t(PI.all) %% V.all
181	!	UG.all <- U.all %*% Gamma.all
182	!	UG.all2 <- UG.all %*% UG.all
183	!	trace.UGamma2 <- sum(diag(UG.all2))
184		}
185		}
186
187	!	if (Satterthwaite && !scaled.shifted) {
188	!	cd <- trace.UGamma2 / trace.UGamma
189	!	df.delta <- trace.UGamma^2 / trace.UGamma2
190	!	T.delta <- (T0 - T1) / cd
191	!	a <- as.numeric(NA)
192	!	b <- as.numeric(NA)
193	!	} else if (Satterthwaite && scaled.shifted) {
194	!	a <- sqrt(m / trace.UGamma2)
195		# b <- m - sqrt(m * trace.UGamma^2 / trace.UGamma2)
196	!	b <- m - a * trace.UGamma
197	!	df.delta <- m
198	!	T.delta <- (T0 - T1) * a + b
199	!	cd <- as.numeric(NA)
200		} else {
201	!	cd <- 1 / m * trace.UGamma
202	!	df.delta <- m
203	!	T.delta <- (T0 - T1) / cd
204	!	a <- as.numeric(NA)
205	!	b <- as.numeric(NA)
206		}
207
208	!	list(
209	!	T.delta = T.delta, scaling.factor = cd, df.delta = df.delta,
210	!	trace.UGamma = trace.UGamma, trace.UGamma2 = trace.UGamma2,
211	!	a = a, b = b
212		)
213		}
214
215		lav_test_diff_SatorraBentler2001 <- function(m1, m0, test = 2) {
216		# extract information from m1 and m2
217	!	T1 <- m1@test[[1]]$stat
218	!	r1 <- m1@test[[1]]$df
219	!	c1 <- m1@test[[test]]$scaling.factor
220
221		## check for situations when scaling.factor would be NA
222	!	if (r1 == 0) {
223		## saturated model
224	!	c1 <- 1 # canceled out by 0 when calculating "cd"
225
226	!	} else if (r1 > 0 && isTRUE(all.equal(T1, 0))) {
227		## perfect fit
228	!	c1 <- 0 # cancels out r1 when calculating "cd"
229		}
230
231	!	T0 <- m0@test[[1]]$stat
232	!	r0 <- m0@test[[1]]$df
233	!	c0 <- m0@test[[test]]$scaling.factor
234
235		# m = difference between the df's
236	!	m <- r0 - r1
237
238		# check for identical df setting
239	!	if (m == 0L) {
240	!	return(list(
241	!	T.delta = (T0 - T1), scaling.factor = as.numeric(NA),
242	!	df.delta = m
243		))
244		}
245
246		# compute c_d
247	!	cd <- (r0 * c0 - r1 * c1) / m
248
249		# warn if cd is negative
250	!	if (cd < 0) {
251	!	lav_msg_warn(gettext("scaling factor is negative"))
252	!	cd <- as.numeric(NA)
253		}
254
255		# compute scaled difference test
256	!	T.delta <- (T0 - T1) / cd
257
258	!	list(T.delta = T.delta, scaling.factor = cd, df.delta = m)
259		}
260
261		lav_test_diff_SatorraBentler2010 <- function(m1, m0, test = 2,
262		H1 = FALSE) {
263		### FIXME: check if models are nested at the parameter level!!!
264
265		# extract information from m1 and m2
266	!	T1 <- m1@test[[1]]$stat
267	!	r1 <- m1@test[[1]]$df
268	!	c1 <- m1@test[[test]]$scaling.factor
269	!	if (r1 == 0) { # saturated model
270	!	c1 <- 1
271		}
272
273	!	T0 <- m0@test[[1]]$stat
274	!	r0 <- m0@test[[1]]$df
275	!	c0 <- m0@test[[test]]$scaling.factor
276	!	if (r0 == 0) { # should never happen
277	!	c0 <- 1
278		}
279
280		# m = difference between the df's
281	!	m <- r0 - r1
282
283		# check for identical df setting
284	!	if (m == 0L) {
285	!	return(list(
286	!	T.delta = (T0 - T1), scaling.factor = as.numeric(NA),
287	!	df.delta = m
288		))
289		}
290
291		# generate `M10' model
292	!	if (H1) {
293		# M0 with M1 parameters
294	!	M01 <- lav_test_diff_m10(m0, m1, test = TRUE)
295	!	c01 <- M01@test[[test]]$scaling.factor
296
297		# check if vcov is positive definite (new in 0.6)
298		# if not, we may get negative values
299	!	eigvals <- eigen(lavTech(M01, "information"),
300	!	symmetric = TRUE, only.values = TRUE
301	!	)$values
302	!	if (any(eigvals < -1 * .Machine$double.eps^(3 / 4))) {
303	!	lav_msg_warn(gettext(
304	!	"information matrix of the M01 model is not positive definite."
305		))
306		# " As a result, the scale-factor can not be computed.")
307		# cd <- as.numeric(NA)
308		} # else {
309		# compute c_d
310		# cd.01 <- (r0 * c01 - r1 * c0) / m ???
311	!	cd <- (r0 * c0 - r1 * c01) / m
312		# }
313		} else {
314		# M1 with M0 parameters (as in Satorra & Bentler 2010)
315	!	M10 <- lav_test_diff_m10(m1, m0, test = TRUE)
316	!	c10 <- M10@test[[test]]$scaling.factor
317
318		# check if vcov is positive definite (new in 0.6)
319		# if not, we may get negative values
320	!	eigvals <- eigen(lavTech(M10, "information"),
321	!	symmetric = TRUE, only.values = TRUE
322	!	)$values
323	!	if (any(eigvals < -1 * .Machine$double.eps^(3 / 4))) {
324	!	lav_msg_warn(gettext(
325	!	"information matrix of the M10 model is not positive definite."
326		))
327		# " As a result, the scale-factor can not be computed.")
328		# cd <- as.numeric(NA)
329		} # else {
330		# compute c_d
331	!	cd <- (r0 * c0 - r1 * c10) / m
332		# }
333		}
334
335		# compute scaled difference test
336	!	T.delta <- (T0 - T1) / cd
337
338	!	list(
339	!	T.delta = T.delta, scaling.factor = cd, df.delta = m,
340	!	T.delta.unscaled = (T0 - T1)
341		)
342		}
343
344		# create a new model 'm10', where we use model 'm1', but we
345		# inject it with the values of 'm0'
346		lav_test_diff_m10 <- function(m1, m0, test = FALSE) {
347		# switch of verbose/se/test
348	!	Options <- m1@Options
349		# switch of optim.gradient check
350	!	Options$check.gradient <- FALSE
351
352		# should we compute se/test statistics?
353	!	if (!test) {
354	!	Options$se <- "none"
355	!	Options$test <- "none"
356		}
357
358	!	PT.M0 <- lav_partable_set_cache(m0@ParTable, m0@pta)
359	!	PT.M1 <- lav_partable_set_cache(m1@ParTable, m1@pta)
360
361		# `extend' PT.M1 partable to include all `fixed-to-zero parameters'
362	!	PT.M1.FULL <- lav_partable_full(
363	!	partable = PT.M1,
364	!	free = TRUE, start = TRUE
365		)
366	!	PT.M1.extended <- lav_partable_merge(PT.M1, PT.M1.FULL,
367	!	remove.duplicated = TRUE, warn = FALSE
368		)
369
370		# remove most columns
371	!	PT.M1.extended$start <- NULL # new in 0.6-4! (otherwise, they are used)
372	!	PT.M1.extended$est <- NULL
373	!	PT.M1.extended$se <- NULL
374
375		# in addition, use 'NA' for free parameters in ustart column
376	!	free.par.idx <- which(PT.M1.extended$free > 0L)
377	!	PT.M1.extended$ustart[free.par.idx] <- as.numeric(NA)
378
379		# `extend' PT.M0 partable to include all `fixed-to-zero parameters'
380	!	PT.M0.FULL <- lav_partable_full(
381	!	partable = PT.M0,
382	!	free = TRUE, start = TRUE
383		)
384	!	PT.M0.extended <- lav_partable_merge(PT.M0, PT.M0.FULL,
385	!	remove.duplicated = TRUE, warn = FALSE
386		)
387		# remove most columns, but not 'est'
388	!	PT.M0.extended$ustart <- NULL
389	!	PT.M0.extended$start <- NULL
390	!	PT.M0.extended$se <- NULL
391
392
393		# FIXME:
394		# - check if H0 does not contain additional parameters...
395
396	!	Options$optim.method <- "none"
397	!	Options$optim.force.converged <- TRUE
398	!	Options$baseline <- FALSE
399	!	Options$h1 <- TRUE # needed after all (yuan.benter.mplus)
400	!	Options$start <- PT.M0.extended # new in 0.6!
401	!	m10 <- lavaan(
402	!	model = PT.M1.extended,
403	!	slotOptions = Options,
404	!	slotSampleStats = m1@SampleStats,
405	!	slotData = m1@Data,
406	!	slotCache = m1@Cache,
407	!	verbose = FALSE
408		)
409
410	!	m10
411		}
412
413		# compute the `A' matrix: the jacobian of the constraint function a(\delta)
414		# (see Satorra 2000)
415		#
416		#
417		#
418		lav_test_diff_A <- function(m1, m0, method = "delta", reference = "H1") {
419		# FIXME!!!!
420
421	!	if (method == "exact") {
422	!	if (reference == "H1") {
423	!	af <- lav_test_diff_af_h1(m1 = m1, m0 = m0)
424	!	xx <- m1@optim$x
425		} else { # evaluate under H0
426	!	lav_msg_stop(gettext("not ready yet"))
427		# af <- .test_compute_partable_A_diff_h0(m1 = m1, m0 = m0)
428	!	xx <- m0@optim$x
429		}
430	!	A <- try(lav_func_jacobian_complex(func = af, x = xx), silent = TRUE)
431	!	if (inherits(A, "try-error")) {
432	!	A <- lav_func_jacobian_simple(func = af, x = xx)
433		}
434	!	} else if (method == "delta") {
435		# use a numeric approximation of `A'
436	!	Delta1.list <- lav_model_delta(m1@Model)
437	!	Delta0.list <- lav_model_delta(m0@Model)
438	!	Delta1 <- do.call(rbind, Delta1.list)
439	!	Delta0 <- do.call(rbind, Delta0.list)
440
441		# take into account equality constraints m0
442	!	if (m0@Model@eq.constraints) {
443	!	Delta0 <- Delta0 %*% m0@Model@eq.constraints.K
444	!	} else if (m0@Model@ceq.simple.only) {
445	!	Delta0 <- Delta0 %*% t(m0@Model@ceq.simple.K)
446		}
447
448		# take into account equality constraints m1
449	!	if (m1@Model@eq.constraints) {
450	!	Delta1 <- Delta1 %*% m1@Model@eq.constraints.K
451	!	} else if (m1@Model@ceq.simple.only) {
452	!	Delta1 <- Delta1 %*% t(m1@Model@ceq.simple.K)
453		}
454
455		# H <- solve(t(Delta1) %% Delta1) %% t(Delta1) %*% Delta0
456	!	H <- MASS::ginv(Delta1) %*% Delta0
457	!	A <- t(lav_matrix_orthogonal_complement(H))
458		}
459
460	!	A
461		}
462
463
464		# for each parameter in H1 (m1), see if we have somehow constrained
465		# this parameter under H0 (m0)
466		#
467		# since we work 'under H0', we need to use the labels/constraints/def
468		# as they appear in H0. Unfortunately, the order of the parameters, and
469		# even the (p)labels may be different in the two models...
470		#
471		# Therefore, we will attempt to:
472		# - change the 'order' of the 'free' column in m0, so that they map to
473		# to the 'x' that we will provide from H1
474		# - the plabels used in "==" constraints must be renamed, if necessary
475		#
476		lav_test_diff_af_h1 <- function(m1, m0) {
477	!	PT.M0 <- lav_partable_set_cache(parTable(m0), m0@pta)
478	!	PT.M1 <- lav_partable_set_cache(parTable(m1), m1@pta)
479
480		# select .p*. parameters only
481	!	M0.p.idx <- which(grepl("\\.p", PT.M0$plabel))
482	!	np0 <- length(M0.p.idx)
483	!	M1.p.idx <- which(grepl("\\.p", PT.M1$plabel))
484	!	np1 <- length(M1.p.idx)
485
486		# check if parameter space is the same
487	!	if (np0 != np1) {
488	!	lav_msg_stop(gettext(
489	!	"unconstrained parameter set is not the same in m0 and m1"))
490		}
491
492		# split partable in 'parameter' and 'constraints' section
493	!	PT.M0.part1 <- PT.M0[M0.p.idx, ]
494	!	PT.M0.part2 <- PT.M0[-M0.p.idx, ]
495
496	!	PT.M1.part1 <- PT.M1[M1.p.idx, ]
497	!	PT.M1.part2 <- PT.M1[-M1.p.idx, ]
498
499		# figure out relationship between m0 and m1
500	!	p1.id <- lav_partable_map_id_p1_in_p2(PT.M0.part1, PT.M1.part1)
501	!	p0.free.idx <- which(PT.M0.part1$free > 0)
502
503		# change 'free' order in m0
504		# NOTE: this only works all the free parameters in h0 are also free
505		# in h1 (and if not, they will become fixed in h0)
506	!	PT.M0.part1$free[p0.free.idx] <-
507	!	PT.M1.part1$free[PT.M0.part1$id[p1.id][p0.free.idx]]
508
509		# paste back
510	!	PT.M0 <- rbind(PT.M0.part1, PT.M0.part2)
511	!	PT.M1 <- rbind(PT.M1.part1, PT.M1.part2)
512
513		# `extend' PT.M1 partable to include all `fixed-to-zero parameters'
514	!	PT.M1.FULL <- lav_partable_full(
515	!	partable = PT.M1,
516	!	free = TRUE, start = TRUE
517		)
518	!	PT.M1.extended <- lav_partable_merge(PT.M1, PT.M1.FULL,
519	!	remove.duplicated = TRUE, warn = FALSE
520		)
521
522		# `extend' PT.M0 partable to include all `fixed-to-zero parameters'
523	!	PT.M0.FULL <- lav_partable_full(
524	!	partable = PT.M0,
525	!	free = TRUE, start = TRUE
526		)
527	!	PT.M0.extended <- lav_partable_merge(PT.M0, PT.M0.FULL,
528	!	remove.duplicated = TRUE, warn = FALSE
529		)
530
531	!	p1 <- PT.M1.extended
532	!	np1 <- length(p1$lhs)
533	!	p0 <- PT.M0.extended
534	!	np0 <- length(p0$lhs)
535
536	!	con.function <- function() NULL
537	!	formals(con.function) <- alist(.x. = , ... = )
538	!	BODY.txt <- paste("{\nout <- numeric(0L)\n", sep = "")
539
540
541		# first handle def + == constraints
542		# but FIRST, remove == constraints that also appear in H1!!!
543
544		# remove equivalent eq constraints from p0
545	!	P0 <- p0
546
547	!	p0.eq.idx <- which(p0$op == "==")
548	!	p1.eq.idx <- which(p1$op == "==")
549	!	p0.remove.idx <- integer(0L)
550	!	if (length(p0.eq.idx) > 0L) {
551	!	for (i in seq_along(p0.eq.idx)) {
552		# e0 in p0
553	!	e0 <- p0.eq.idx[i]
554	!	lhs <- p0$lhs[e0]
555	!	rhs <- p0$rhs[e0]
556
557		# do we have an equivalent constraint in H1?
558		# NOTE!! the (p)labels may differ
559
560		# SO, we will use an 'empirical' approach: if we fill in (random)
561		# values, and work out the constraint, do we get identical values?
562		# if yes, constraint is equivalent, and we should NOT add it here
563
564	!	if (length(p1.eq.idx) > 0) {
565		# generate random parameter values
566	!	xx1 <- rnorm(length(M1.p.idx))
567	!	xx0 <- xx1[p1.id]
568
569	!	con.h0.value <- m0@Model@ceq.function(xx0)[i]
570	!	con.h1.values <- m1@Model@ceq.function(xx1)
571
572	!	if (con.h0.value %in% con.h1.values) {
573	!	p0.remove.idx <- c(p0.remove.idx, e0)
574		}
575		}
576		}
577		}
578	!	if (length(p0.remove.idx) > 0L) {
579	!	P0 <- P0[-p0.remove.idx, ]
580		}
581
582		# only for the UNIQUE equality constraints in H0, generate syntax
583	!	DEFCON.txt <- lav_partable_constraints_ceq(P0, txtOnly = TRUE)
584	!	BODY.txt <- paste(BODY.txt, DEFCON.txt, "\n", sep = "")
585
586
587		# for each parameter in p1, we 'check' is it is fixed to a constant in p0
588	!	ncon <- length(which(P0$op == "=="))
589	!	for (i in seq_len(np1)) {
590		# p in p1
591	!	lhs <- p1$lhs[i]
592	!	op <- p1$op[i]
593	!	rhs <- p1$rhs[i]
594	!	group <- p1$group[i]
595
596		# ignore '==', '<', '>' and ':=' for now
597	!	if (op == "==" \|\| op == ">" \|\| op == "<" \|\| op == ":=") next
598
599		# search for corresponding parameter in p0
600	!	p0.idx <- which(p0$lhs == lhs & p0$op == op & p0$rhs == rhs &
601	!	p0$group == group)
602	!	if (length(p0.idx) == 0L) {
603	!	lav_msg_stop(
604	!	gettextf("parameter in H1 not found in H0: %s",
605	!	paste(lhs, op, rhs, "(group = ", group, ")", sep = " ")
606		))
607		}
608
609		# 4 possibilities: p is free/fixed in p1, p is free/fixed in p0
610	!	if (p1$free[i] == 0L) {
611	!	if (p0$free[p0.idx] == 0L) {
612		# match, nothing to do
613		} else {
614	!	lav_msg_warn(
615	!	gettextf("fixed parameter in H1 is free in H0: %s",
616	!	paste("\"", lhs, " ", op, " ", rhs,
617	!	"\" (group = ", group, ")",
618	!	sep = ""
619		)
620		))
621		}
622		} else {
623	!	if (p0$free[p0.idx] == 0L) {
624		# match, this is a contrained parameter in H0
625	!	ncon <- ncon + 1L
626	!	BODY.txt <- paste(BODY.txt,
627	!	"out[", ncon, "] = .x.[", p1$free[i], "] - ",
628	!	p0$ustart[p0.idx], "\n",
629	!	sep = ""
630		)
631	!	next
632		} else {
633		# match, nothing to do
634		}
635		}
636		}
637
638
639		# wrap function
640	!	BODY.txt <- paste(BODY.txt, "return(out)\n}\n", sep = "")
641	!	body(con.function) <- parse(file = "", text = BODY.txt)
642
643	!	con.function
644		}

1		# the multivariate linear model using maximum likelihood
2
3		# 1) loglikelihood (from raw data, or sample statistics)
4		# 2) derivatives with respect to Beta, res.cov, vech(res.cov)
5		# 3) casewise scores with respect to Beta, vech(res.cov), Beta + vech(res.cov)
6		# 4) hessian Beta + vech(res.cov)
7		# 5) information h0 Beta + vech(res.cov)
8		# 5a: (unit) expected information
9		# 5b: (unit) observed information
10		# 5c: (unit) first.order information
11
12		# YR 24 Mar 2016: first version
13		# YR 20 Jan 2017: removed added 'N' in many equations, to be consistent with
14		# lav_mvnorm_*
15		# YR 18 Okt 2018: add 'information' functions, change arguments
16		# (X -> eXo, Sigma -> res.cov, Beta -> res.int + res.slopes)
17
18		# 1. loglikelihood
19
20		# 1a. input is raw data
21		lav_mvreg_loglik_data <- function(Y = NULL,
22		eXo = NULL, # no intercept
23		Beta = NULL,
24		res.int = NULL,
25		res.slopes = NULL,
26		res.cov = NULL,
27		casewise = FALSE,
28		Sinv.method = "eigen") {
29	!	Y <- unname(Y)
30	!	Q <- NCOL(Y)
31	!	N <- NROW(Y)
32	!	X <- cbind(1, unname(eXo))
33
34		# construct model-implied Beta
35	!	if (is.null(Beta)) {
36	!	Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
37		}
38
39	!	if (casewise) {
40	!	LOG.2PI <- log(2 * pi)
41
42		# invert res.cov
43	!	if (Sinv.method == "chol") {
44	!	cS <- chol(res.cov)
45	!	icS <- backsolve(cS, diag(Q))
46	!	logdet <- -2 * sum(log(diag(icS)))
47
48	!	RES <- Y - X %*% Beta
49	!	DIST <- rowSums((RES %*% icS)^2)
50		} else {
51	!	res.cov.inv <- lav_matrix_symmetric_inverse(
52	!	S = res.cov, logdet = TRUE,
53	!	Sinv.method = Sinv.method
54		)
55	!	logdet <- attr(res.cov.inv, "logdet")
56
57	!	RES <- Y - X %*% Beta
58	!	DIST <- rowSums(RES %% res.cov.inv RES)
59		}
60
61	!	loglik <- -(Q * LOG.2PI + logdet + DIST) / 2
62		} else {
63		# invert res.cov
64	!	res.cov.inv <- lav_matrix_symmetric_inverse(
65	!	S = res.cov, logdet = TRUE,
66	!	Sinv.method = Sinv.method
67		)
68	!	logdet <- attr(res.cov.inv, "logdet")
69
70	!	RES <- Y - X %*% Beta
71		# TOTAL <- TR( (Y - X%%Beta) %% res.cov.inv %% t(Y - X%%Beta) )
72	!	TOTAL <- sum(rowSums(RES %% res.cov.inv RES))
73	!	loglik <- -(N * Q / 2) * log(2 * pi) - (N / 2) * logdet - (1 / 2) * TOTAL
74		}
75
76	!	loglik
77		}
78
79
80		# 2b. input are sample statistics (res.int, res.slopes, res.cov, N) only
81		lav_mvreg_loglik_samplestats <- function(sample.res.int = NULL,
82		sample.res.slopes = NULL,
83		sample.res.cov = NULL,
84		sample.mean.x = NULL,
85		sample.cov.x = NULL,
86		sample.nobs = NULL,
87		Beta = NULL, # optional
88		res.int = NULL,
89		res.slopes = NULL,
90		res.cov = NULL,
91		Sinv.method = "eigen",
92		res.cov.inv = NULL) {
93	!	Q <- NCOL(sample.res.cov)
94	!	N <- sample.nobs
95	!	LOG.2PI <- log(2 * pi)
96
97		# construct model-implied Beta
98	!	if (is.null(Beta)) {
99	!	Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
100		}
101
102		# construct 'saturated' (sample-based) B
103	!	sample.B <- rbind(matrix(sample.res.int, nrow = 1), t(sample.res.slopes))
104
105		# construct sample.xx = 1/N*crossprod(X1) (including intercept)
106	!	sample.xx <- rbind(
107	!	cbind(1, matrix(sample.mean.x, nrow = 1, )),
108	!	cbind(
109	!	matrix(sample.mean.x, ncol = 1),
110	!	sample.cov.x + tcrossprod(sample.mean.x)
111		)
112		)
113
114		# res.cov.inv
115	!	if (is.null(res.cov.inv)) {
116	!	res.cov.inv <- lav_matrix_symmetric_inverse(
117	!	S = res.cov, logdet = TRUE,
118	!	Sinv.method = Sinv.method
119		)
120	!	logdet <- attr(res.cov.inv, "logdet")
121		} else {
122	!	logdet <- attr(res.cov.inv, "logdet")
123	!	if (is.null(logdet)) {
124		# compute - ln\|res.cov.inv\|
125	!	ev <- eigen(res.cov.inv, symmetric = TRUE, only.values = TRUE)
126	!	logdet <- -1 * sum(log(ev$values))
127		}
128		}
129
130		# tr(res.cov^{-1} %*% S)
131	!	DIST1 <- sum(res.cov.inv * sample.res.cov)
132
133		# tr( res.cov^{-1} (B-beta)' X'X (B-beta)
134	!	Diff <- sample.B - Beta
135	!	DIST2 <- sum(res.cov.inv * crossprod(Diff, sample.xx) %*% Diff)
136
137	!	loglik <- -(N / 2) * (Q * log(2 * pi) + logdet + DIST1 + DIST2)
138
139	!	loglik
140		}
141
142
143
144
145		# 2. Derivatives
146
147		# 2a. derivative logl with respect to Beta (=intercepts and slopes)
148		lav_mvreg_dlogl_dbeta <- function(Y = NULL,
149		eXo = NULL,
150		Beta = NULL,
151		res.int = NULL,
152		res.slopes = NULL,
153		res.cov = NULL,
154		Sinv.method = "eigen",
155		res.cov.inv = NULL) {
156	!	Y <- unname(Y)
157	!	X <- cbind(1, unname(eXo))
158
159		# construct model-implied Beta
160	!	if (is.null(Beta)) {
161	!	Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
162		}
163
164		# res.cov.inv
165	!	if (is.null(res.cov.inv)) {
166		# invert res.cov
167	!	res.cov.inv <- lav_matrix_symmetric_inverse(
168	!	S = res.cov, logdet = FALSE,
169	!	Sinv.method = Sinv.method
170		)
171		}
172
173		# substract 'X %*% Beta' from Y
174	!	RES <- Y - X %*% Beta
175
176		# derivative
177	!	dbeta <- as.numeric(t(X) %% RES %% res.cov.inv)
178
179	!	dbeta
180		}
181
182		# 2b: derivative logl with respect to res.cov (full matrix, ignoring symmetry)
183		lav_mvreg_dlogl_drescov <- function(Y = NULL,
184		eXo = NULL,
185		Beta = NULL,
186		res.cov = NULL,
187		res.int = NULL,
188		res.slopes = NULL,
189		Sinv.method = "eigen",
190		res.cov.inv = NULL) {
191	!	Y <- unname(Y)
192	!	N <- NROW(Y)
193	!	X <- cbind(1, unname(eXo))
194
195		# construct model-implied Beta
196	!	if (is.null(Beta)) {
197	!	Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
198		}
199
200		# res.cov.in
201	!	if (is.null(res.cov.inv)) {
202		# invert res.cov
203	!	res.cov.inv <- lav_matrix_symmetric_inverse(
204	!	S = res.cov, logdet = FALSE,
205	!	Sinv.method = Sinv.method
206		)
207		}
208
209		# substract 'X %*% Beta' from Y
210	!	RES <- Y - X %*% Beta
211
212		# W.tilde
213	!	W.tilde <- crossprod(RES) / N
214
215		# derivative
216	!	dres.cov <- -(N / 2) * (res.cov.inv - (res.cov.inv %% W.tilde %% res.cov.inv))
217
218	!	dres.cov
219		}
220
221		# 2c: derivative logl with respect to vech(res.cov)
222		lav_mvreg_dlogl_dvechrescov <- function(Y = NULL,
223		eXo = NULL,
224		Beta = NULL,
225		res.int = NULL,
226		res.slopes = NULL,
227		res.cov = NULL,
228		Sinv.method = "eigen",
229		res.cov.inv = NULL) {
230	!	Y <- unname(Y)
231	!	N <- NROW(Y)
232	!	X <- cbind(1, unname(eXo))
233
234		# construct model-implied Beta
235	!	if (is.null(Beta)) {
236	!	Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
237		}
238
239		# res.cov.inv
240	!	if (is.null(res.cov.inv)) {
241		# invert res.cov
242	!	res.cov.inv <- lav_matrix_symmetric_inverse(
243	!	S = res.cov, logdet = FALSE,
244	!	Sinv.method = Sinv.method
245		)
246		}
247
248		# substract 'X %*% Beta' from Y
249	!	RES <- Y - X %*% Beta
250
251		# W.tilde
252	!	W.tilde <- crossprod(RES) / N
253
254		# derivative
255	!	dres.cov <- -(N / 2) * (res.cov.inv - (res.cov.inv %% W.tilde %% res.cov.inv))
256	!	dvechres.cov <- as.numeric(lav_matrix_duplication_pre(
257	!	as.matrix(lav_matrix_vec(dres.cov))
258		))
259
260	!	dvechres.cov
261		}
262
263
264		# 3. Casewise scores
265
266		# 3a: casewise scores with respect to Beta (=intercepts and slopes)
267		# column order: Y1_int, Y1_x1, Y1_x2, ...\| Y2_int, Y2_x1, Y2_x2, ... \|
268		lav_mvreg_scores_beta <- function(Y = NULL,
269		eXo = NULL,
270		Beta = NULL,
271		res.int = NULL,
272		res.slopes = NULL,
273		res.cov = NULL,
274		Sinv.method = "eigen",
275		res.cov.inv = NULL) {
276	!	Y <- unname(Y)
277	!	Q <- NCOL(Y)
278	!	X <- cbind(1, unname(eXo))
279	!	P <- NCOL(X)
280
281		# construct model-implied Beta
282	!	if (is.null(Beta)) {
283	!	Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
284		}
285
286		# res.cov.inv
287	!	if (is.null(res.cov.inv)) {
288		# invert res.cov
289	!	res.cov.inv <- lav_matrix_symmetric_inverse(
290	!	S = res.cov, logdet = FALSE,
291	!	Sinv.method = Sinv.method
292		)
293		}
294
295		# substract Mu
296	!	RES <- Y - X %*% Beta
297
298		# post-multiply with res.cov.inv
299	!	RES <- RES %*% res.cov.inv
300
301	!	SC.Beta <- X[, rep(1:P, times = Q), drop = FALSE] *
302	!	RES[, rep(1:Q, each = P), drop = FALSE]
303
304	!	SC.Beta
305		}
306
307
308		# 3b: casewise scores with respect to vech(res.cov)
309		lav_mvreg_scores_vech_sigma <- function(Y = NULL,
310		eXo = NULL,
311		Beta = NULL,
312		res.int = NULL,
313		res.slopes = NULL,
314		res.cov = NULL,
315		Sinv.method = "eigen",
316		res.cov.inv = NULL) {
317	!	Y <- unname(Y)
318	!	Q <- NCOL(Y)
319	!	X <- cbind(1, unname(eXo))
320
321		# construct model-implied Beta
322	!	if (is.null(Beta)) {
323	!	Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
324		}
325
326		# res.cov.inv
327	!	if (is.null(res.cov.inv)) {
328		# invert res.cov
329	!	res.cov.inv <- lav_matrix_symmetric_inverse(
330	!	S = res.cov, logdet = FALSE,
331	!	Sinv.method = Sinv.method
332		)
333		}
334
335		# vech(res.cov.inv)
336	!	isigma <- lav_matrix_vech(res.cov.inv)
337
338		# substract X %*% Beta
339	!	RES <- Y - X %*% Beta
340
341		# postmultiply with res.cov.inv
342	!	RES <- RES %*% res.cov.inv
343
344		# tcrossprod
345	!	idx1 <- lav_matrix_vech_col_idx(Q)
346	!	idx2 <- lav_matrix_vech_row_idx(Q)
347	!	Z <- RES[, idx1] * RES[, idx2]
348
349		# substract isigma from each row
350	!	SC <- t(t(Z) - isigma)
351
352		# adjust for vech (and avoiding the 1/2 factor)
353	!	SC[, lav_matrix_diagh_idx(Q)] <- SC[, lav_matrix_diagh_idx(Q)] / 2
354
355	!	SC
356		}
357
358
359		# 3c: casewise scores with respect to beta + vech(res.cov)
360		lav_mvreg_scores_beta_vech_sigma <- function(Y = NULL,
361		eXo = NULL,
362		Beta = NULL,
363		res.int = NULL,
364		res.slopes = NULL,
365		res.cov = NULL,
366		Sinv.method = "eigen",
367		res.cov.inv = NULL) {
368	!	Y <- unname(Y)
369	!	Q <- NCOL(Y)
370	!	X <- cbind(1, unname(eXo))
371	!	P <- NCOL(X)
372
373		# construct model-implied Beta
374	!	if (is.null(Beta)) {
375	!	Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
376		}
377
378		# res.cov.inv
379	!	if (is.null(res.cov.inv)) {
380		# invert res.cov
381	!	res.cov.inv <- lav_matrix_symmetric_inverse(
382	!	S = res.cov, logdet = FALSE,
383	!	Sinv.method = Sinv.method
384		)
385		}
386
387		# vech(res.cov.inv)
388	!	isigma <- lav_matrix_vech(res.cov.inv)
389
390		# substract X %*% Beta
391	!	RES <- Y - X %*% Beta
392
393		# postmultiply with res.cov.inv
394	!	RES <- RES %*% res.cov.inv
395
396	!	SC.Beta <- X[, rep(1:P, times = Q), drop = FALSE] *
397	!	RES[, rep(1:Q, each = P), drop = FALSE]
398
399		# tcrossprod
400	!	idx1 <- lav_matrix_vech_col_idx(Q)
401	!	idx2 <- lav_matrix_vech_row_idx(Q)
402	!	Z <- RES[, idx1] * RES[, idx2]
403
404		# substract isigma from each row
405	!	SC <- t(t(Z) - isigma)
406
407		# adjust for vech (and avoiding the 1/2 factor)
408	!	SC[, lav_matrix_diagh_idx(Q)] <- SC[, lav_matrix_diagh_idx(Q)] / 2
409
410	!	cbind(SC.Beta, SC)
411		}
412
413		# 4. hessian of logl
414
415		# 4a. hessian logl Beta and vech(res.cov) from raw data
416		lav_mvreg_logl_hessian_data <- function(Y = NULL,
417		eXo = NULL, # no int
418		Beta = NULL, # int+slopes
419		res.int = NULL,
420		res.slopes = NULL,
421		res.cov = NULL,
422		res.cov.inv = NULL,
423		Sinv.method = "eigen") {
424		# sample size
425	!	N <- NROW(Y)
426
427		# observed information
428	!	observed <- lav_mvreg_information_observed_data(
429	!	Y = Y, eXo = eXo,
430	!	Beta = Beta, res.int = res.int, res.slopes = res.slopes,
431	!	res.cov = res.cov, res.cov.inv = res.cov.inv,
432	!	Sinv.method = Sinv.method
433		)
434
435		# hessian
436	!	-N * observed
437		}
438
439		# 4b. hessian logl Beta and vech(res.cov) from samplestats
440		lav_mvreg_logl_hessian_samplestats <- function(sample.res.int = NULL,
441		sample.res.slopes = NULL,
442		sample.res.cov = NULL,
443		sample.mean.x = NULL,
444		sample.cov.x = NULL,
445		sample.nobs = NULL,
446		Beta = NULL, # int + slopes
447		res.int = NULL, # intercepts only
448		res.slopes = NULL, # slopes only (y x x)
449		res.cov = NULL, # res.cov
450		Sinv.method = "eigen",
451		res.cov.inv = NULL) {
452		# sample size
453	!	N <- sample.nobs
454
455		# information
456	!	observed <- lav_mvreg_information_observed_samplestats(
457	!	sample.res.int = sample.res.int, sample.res.slopes = sample.res.slopes,
458	!	sample.res.cov = sample.res.cov, sample.mean.x = sample.mean.x,
459	!	sample.cov.x = sample.cov.x, Beta = Beta, res.int = res.int,
460	!	res.slopes = res.slopes, res.cov = res.cov, Sinv.method = Sinv.method,
461	!	res.cov.inv = res.cov.inv
462		)
463
464		# hessian
465	!	-N * observed
466		}
467
468
469		# Information h0
470
471		# 5a: unit expected information h0 Beta and vech(res.cov)
472		lav_mvreg_information_expected <- function(Y = NULL, # not used
473		eXo = NULL, # not used
474		sample.mean.x = NULL,
475		sample.cov.x = NULL,
476		sample.nobs = NULL,
477		Beta = NULL, # not used
478		res.int = NULL, # not used
479		res.slopes = NULL, # not used
480		res.cov = NULL,
481		res.cov.inv = NULL,
482		Sinv.method = "eigen") {
483	!	eXo <- unname(eXo)
484
485		# res.cov.inv
486	!	if (is.null(res.cov.inv)) {
487		# invert res.cov
488	!	res.cov.inv <- lav_matrix_symmetric_inverse(
489	!	S = res.cov, logdet = FALSE,
490	!	Sinv.method = Sinv.method
491		)
492		}
493
494		# N
495	!	if (is.null(sample.nobs)) {
496	!	sample.nobs <- nrow(eXo) # hopefully not NULL either
497		} else {
498	!	N <- sample.nobs
499		}
500
501		# sample.mean.x + sample.cov.x
502	!	if (is.null(sample.mean.x)) {
503	!	sample.mean.x <- base::.colMeans(eXo, m = NROW(eXo), n = NCOL(eXo))
504		}
505	!	if (is.null(sample.cov.x)) {
506	!	sample.cov.x <- lav_matrix_cov(eXo)
507		}
508
509		# construct sample.xx = 1/N*crossprod(X1) (including intercept)
510	!	sample.xx <- rbind(
511	!	cbind(1, matrix(sample.mean.x, nrow = 1, )),
512	!	cbind(
513	!	matrix(sample.mean.x, ncol = 1),
514	!	sample.cov.x + tcrossprod(sample.mean.x)
515		)
516		)
517
518		# expected information
519	!	I11 <- res.cov.inv %x% sample.xx
520		# if (lav_use_lavaanC()) {
521		# I22 <- lavaanC::m_kronecker_dup_pre_post(res.cov.inv, multiplicator = 0.5)
522		# } else {
523	!	I22 <- 0.5 * lav_matrix_duplication_pre_post(res.cov.inv %x% res.cov.inv)
524		# }
525
526	!	lav_matrix_bdiag(I11, I22)
527		}
528
529		# 5b: unit observed information h0
530		lav_mvreg_information_observed_data <- function(Y = NULL,
531		eXo = NULL, # no int
532		Beta = NULL, # int+slopes
533		res.int = NULL,
534		res.slopes = NULL,
535		res.cov = NULL,
536		res.cov.inv = NULL,
537		Sinv.method = "eigen") {
538		# create sample statistics
539	!	Y <- unname(Y)
540	!	X1 <- cbind(1, unname(eXo))
541	!	N <- NROW(Y)
542
543		# find 'B'
544	!	QR <- qr(X1)
545	!	sample.B <- qr.coef(QR, Y)
546
547	!	sample.res.int <- as.numeric(sample.B[1, ])
548	!	sample.res.slopes <- t(sample.B[-1, , drop = FALSE]) # transpose!
549	!	sample.res.cov <- cov(qr.resid(QR, Y)) * (N - 1) / N
550	!	sample.mean.x <- base::.colMeans(eXo, m = NROW(eXo), n = NCOL(eXo))
551	!	sample.cov.x <- lav_matrix_cov(eXo)
552
553	!	lav_mvreg_information_observed_samplestats(
554	!	sample.res.int = sample.res.int,
555	!	sample.res.slopes = sample.res.slopes, sample.res.cov = sample.res.cov,
556	!	sample.mean.x = sample.mean.x, sample.cov.x = sample.cov.x,
557	!	Beta = Beta, res.int = res.int, res.slopes = res.slopes,
558	!	res.cov = res.cov, Sinv.method = Sinv.method, res.cov.inv = res.cov.inv
559		)
560		}
561
562
563		# 5b-bis: observed information h0 from sample statistics
564		lav_mvreg_information_observed_samplestats <-
565		function(sample.res.int = NULL,
566		sample.res.slopes = NULL,
567		sample.res.cov = NULL,
568		sample.mean.x = NULL,
569		sample.cov.x = NULL,
570		Beta = NULL, # int + slopes
571		res.int = NULL, # intercepts only
572		res.slopes = NULL, # slopes only (y x x)
573		res.cov = NULL, # res.cov
574		Sinv.method = "eigen",
575		res.cov.inv = NULL) {
576		# construct model-implied Beta
577	!	if (is.null(Beta)) {
578	!	Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes))
579		}
580
581		# construct 'saturated' (sample-based) B
582	!	sample.B <- rbind(matrix(sample.res.int, nrow = 1), t(sample.res.slopes))
583
584		# construct sample.xx = 1/N*crossprod(X1) (including intercept)
585	!	sample.xx <- rbind(
586	!	cbind(1, matrix(sample.mean.x, nrow = 1, )),
587	!	cbind(
588	!	matrix(sample.mean.x, ncol = 1),
589	!	sample.cov.x + tcrossprod(sample.mean.x)
590		)
591		)
592
593		# W.tilde = S + t(B - Beta) %% (1/N)X'X %*% (B - Beta)
594	!	W.tilde <- (sample.res.cov +
595	!	t(sample.B - Beta) %% sample.xx %% (sample.B - Beta))
596
597		# res.cov.inv
598	!	if (is.null(res.cov.inv)) {
599		# invert res.cov
600	!	res.cov.inv <- lav_matrix_symmetric_inverse(
601	!	S = res.cov, logdet = FALSE,
602	!	Sinv.method = Sinv.method
603		)
604		}
605
606	!	H11 <- res.cov.inv %x% sample.xx
607	!	H21 <- lav_matrix_duplication_pre(res.cov.inv %x%
608	!	(res.cov.inv %*% (crossprod(sample.B - Beta, sample.xx))))
609	!	H12 <- t(H21)
610
611	!	AAA <- res.cov.inv %% (2 W.tilde - res.cov) %*% res.cov.inv
612		# if (lav_use_lavaanC()) {
613		# H22 <- lavaanC::m_kronecker_dup_pre_post(res.cov.inv, AAA, 0.5)
614		# } else {
615	!	H22 <- (1 / 2) * lav_matrix_duplication_pre_post(res.cov.inv %x% AAA)
616		# }
617
618	!	out <- rbind(
619	!	cbind(H11, H12),
620	!	cbind(H21, H22)
621		)
622	!	out
623		}
624
625
626		# 5c: unit first-order information h0
627		lav_mvreg_information_firstorder <- function(Y = NULL,
628		eXo = NULL, # no int
629		Beta = NULL, # int+slopes
630		res.int = NULL,
631		res.slopes = NULL,
632		res.cov = NULL,
633		res.cov.inv = NULL,
634		Sinv.method = "eigen") {
635	!	N <- NROW(Y)
636
637		# scores
638	!	SC <- lav_mvreg_scores_beta_vech_sigma(
639	!	Y = Y, eXo = eXo, Beta = Beta,
640	!	res.int = res.int, res.slopes = res.slopes, res.cov = res.cov,
641	!	Sinv.method = Sinv.method, res.cov.inv = res.cov.inv
642		)
643
644	!	crossprod(SC) / N
645		}
646
647
648		# 6: inverted information h0
649
650		# 6a: inverted unit expected information h0 Beta and vech(res.cov)
651		#
652		# lav_mvreg_inverted_information_expected <- function(Y = NULL, # unused!
653		# }

1		# print 'blocks' of test statistics
2		# - blocks with 'scaling.factors' come first (in 'two columns')
3		# - then come the 'single-column' test statistics (eg browne.residual.adf)
4		# - print additional informatiation (eg information matrix, h1.information, ...)
5		# if they deviate from what is used for the standard errors
6
7		# this is used by the summary() function and lavTest(, output = "text")
8
9		# YR 13 Feb 2026: if test[[1]] has stat = NA, skip if there are other tests
10
11		lav_test_print <- function(object, nd = 3L) {
12		# object is list of tests
13	20x	TEST <- object
14
15		# empty list?
16	20x	if (is.null(TEST) \|\| length(TEST) == 0L \|\| !is.list(TEST)) {
17	!	return(character(0L))
18		}
19
20		# test = "none"?
21	20x	if (TEST[[1]]$test == "none") {
22	!	return(character(0L))
23		}
24
25		# remove empty first test (stat = NA) if multiple tests are available)
26	20x	if (length(TEST) > 1L && is.na(TEST[[1]]$stat)) {
27	!	TEST <- TEST[-1]
28		}
29
30		# meta data
31	20x	info <- attr(object, "info")
32	20x	ngroups <- info$ngroups
33	20x	group.label <- info$group.label
34	20x	information <- info$information
35	20x	h1.information <- info$h1.information
36	20x	observed.information <- info$observed.information
37
38		# num format
39	20x	num.format <- paste("%", max(8L, nd + 5L), ".", nd, "f", sep = "")
40
41		# header
42	20x	cat("Model Test User Model:\n")
43
44		# locate 'robust' tests (here: having a scaling factor)
45	20x	has.no.scaling <- unname(sapply(
46	20x	(lapply(TEST, "[[", "scaling.factor")),
47	20x	is.null
48		))
49	20x	robust.idx <- which(!has.no.scaling)
50	20x	non.robust.idx <- which(has.no.scaling)
51	20x	scaled.idx <- 1L
52	20x	if (length(robust.idx) > 0L) {
53	2x	scaled.idx <- which(names(TEST) == TEST[[robust.idx[1]]]$scaled.test)
54	2x	if (length(scaled.idx) == 0L) {
55	1x	scaled.idx <- 1L
56		}
57		# remove 'scaled.test', because it is shown together with robust
58	2x	non.robust.idx <- non.robust.idx[-scaled.idx]
59		}
60	20x	BLOCKS <- c(robust.idx, non.robust.idx)
61	20x	nBlocks <- length(BLOCKS)
62
63		# print out blocks
64	20x	for (block in BLOCKS) {
65		# one or two-columns for this block?
66	20x	if (length(robust.idx) > 0L && block %in% robust.idx) {
67	2x	twocolumn <- TRUE
68		} else {
69	18x	twocolumn <- FALSE
70		}
71
72	20x	if (!twocolumn) {
73		# print label
74	18x	c1 <- c2 <- c3 <- character(0L)
75	18x	if (!is.null(TEST[[block]]$label)) {
76	!	c1 <- c(c1, TEST[[block]]$label)
77	!	c2 <- c(c2, "")
78	!	c3 <- c(c3, "")
79		}
80	18x	if (is.na(TEST[[block]]$df) \|\| TEST[[block]]$df == 0L) {
81	6x	c1 <- c(c1, c("Test statistic", "Degrees of freedom"))
82	6x	c2 <- c(c2, c(
83	6x	sprintf(num.format, TEST[[block]]$stat),
84	6x	ifelse(TEST[[block]]$df %% 1 == 0, # integer
85	6x	TEST[[block]]$df,
86	6x	sprintf(num.format, TEST[[block]]$df)
87		)
88		))
89	6x	c3 <- c(c3, c("", ""))
90		} else {
91	12x	PLABEL <- "P-value"
92	12x	if (!is.null(TEST[[block]]$refdistr)) {
93	12x	if (TEST[[block]]$refdistr == "chisq") {
94	12x	PLABEL <- "P-value (Chi-square)"
95	!	} else if (TEST[[block]]$refdistr == "unknown") {
96	!	PLABEL <- "P-value (Unknown)"
97	!	} else if (TEST[[block]]$refdistr == "bootstrap") {
98	!	PLABEL <- "P-value (Bollen-Stine bootstrap)"
99		}
100		}
101	12x	c1 <- c(c1, c("Test statistic", "Degrees of freedom", PLABEL))
102	12x	c2 <- c(c2, c(
103	12x	sprintf(num.format, TEST[[block]]$stat),
104	12x	ifelse(TEST[[block]]$df %% 1 == 0, # integer
105	12x	TEST[[block]]$df,
106	12x	sprintf(num.format, TEST[[block]]$df)
107		),
108	12x	sprintf(num.format, TEST[[block]]$pvalue)
109		))
110	12x	c3 <- c(c3, c("", "", ""))
111		}
112
113		# two-column
114		} else {
115		# print label
116	2x	c1 <- c2 <- c3 <- character(0L)
117	2x	if (!is.null(TEST[[scaled.idx]]$label)) {
118	!	c1 <- c(c1, TEST[[scaled.idx]]$label)
119	!	c2 <- c(c2, "")
120	!	c3 <- c(c3, "")
121		}
122	2x	if (is.na(TEST[[block]]$df) \|\| TEST[[block]]$df == 0L) {
123	1x	c1 <- c(c1, c("Test Statistic", "Degrees of freedom"))
124	1x	c2 <- c(
125	1x	c2,
126	1x	c(
127	1x	sprintf(num.format, TEST[[scaled.idx]]$stat),
128	1x	ifelse(TEST[[scaled.idx]]$df %% 1 == 0, # integer
129	1x	TEST[[scaled.idx]]$df,
130	1x	sprintf(num.format, TEST[[scaled.idx]]$df)
131		)
132		)
133		)
134	1x	c3 <- c(
135	1x	c3,
136	1x	c(
137	1x	sprintf(num.format, TEST[[block]]$stat),
138	1x	ifelse(TEST[[block]]$df %% 1 == 0, # integer
139	1x	TEST[[block]]$df,
140	1x	sprintf(num.format, TEST[[block]]$df)
141		)
142		)
143		)
144		} else {
145	1x	if (!is.null(TEST[[scaled.idx]]$refdistr)) {
146	1x	if (TEST[[scaled.idx]]$refdistr == "chisq") {
147	!	PLABEL <- "P-value (Chi-square)"
148	1x	} else if (TEST[[scaled.idx]]$refdistr == "unknown") {
149	1x	PLABEL <- "P-value (Unknown)"
150		} else {
151	!	PLABEL <- "P-value"
152		}
153		}
154	1x	c1 <- c(c1, c(
155	1x	"Test Statistic", "Degrees of freedom", PLABEL,
156	1x	"Scaling correction factor"
157		))
158	1x	c2 <- c(
159	1x	c2,
160	1x	c(
161	1x	sprintf(num.format, TEST[[scaled.idx]]$stat),
162	1x	ifelse(TEST[[scaled.idx]]$df %% 1 == 0, # integer
163	1x	TEST[[scaled.idx]]$df,
164	1x	sprintf(num.format, TEST[[scaled.idx]]$df)
165		),
166	1x	sprintf(num.format, TEST[[scaled.idx]]$pvalue), ""
167		)
168		)
169	1x	c3 <- c(
170	1x	c3,
171	1x	c(
172	1x	sprintf(num.format, TEST[[block]]$stat),
173	1x	ifelse(TEST[[block]]$df %% 1 == 0, # integer
174	1x	TEST[[block]]$df,
175	1x	sprintf(num.format, TEST[[block]]$df)
176		),
177	1x	sprintf(num.format, TEST[[block]]$pvalue),
178	1x	sprintf(num.format, TEST[[block]]$scaling.factor)
179		)
180		)
181
182	1x	if (TEST[[block]]$test == "scaled.shifted") {
183	1x	if (ngroups == 1L \|\|
184	1x	length(TEST[[block]]$shift.parameter) == 1L) {
185	1x	c1 <- c(c1, "Shift parameter")
186	1x	c2 <- c(c2, "")
187	1x	c3 <- c(
188	1x	c3,
189	1x	sprintf(num.format, TEST[[block]]$shift.parameter)
190		)
191		} else {
192	!	c1 <- c(c1, "Shift parameter for each group:")
193	!	c2 <- c(c2, "")
194	!	c3 <- c(c3, "")
195	!	for (g in 1:ngroups) {
196	!	c1 <- c(c1, sprintf(" %-38s", group.label[[g]]))
197	!	c2 <- c(c2, "")
198	!	c3 <- c(c3, sprintf(
199	!	num.format,
200	!	TEST[[block]]$shift.parameter[g]
201		))
202		}
203		}
204		} # shift
205
206		# which correction factor?
207	1x	c1 <- c(c1, paste(" ", TEST[[block]]$label, sep = ""))
208	1x	c2 <- c(c2, "")
209	1x	c3 <- c(c3, "")
210		}
211		}
212
213		# if twocolumn, label first row
214	20x	if (twocolumn && block == BLOCKS[1]) {
215	2x	c1 <- c("", c1)
216	2x	c2 <- c("Standard", c2)
217	2x	c3 <- c("Scaled", c3)
218		} else {
219		# empty row
220	18x	c1 <- c("", c1)
221	18x	c2 <- c("", c2)
222	18x	c3 <- c("", c3)
223		}
224
225		# if information type is different from 'se', print it
226	20x	if (length(information) > 1L &&
227	20x	information[1] != information[2]) {
228	!	c1 <- c(c1, "Information")
229	!	tmp.txt <- information[2]
230	!	c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
231	!	substring(tmp.txt, 2),
232	!	sep = ""
233		))
234	!	c3 <- c(c3, "")
235		}
236		# if h1.information type is different from 'se', print it
237	20x	if (length(h1.information) > 1L &&
238	20x	h1.information[1] != h1.information[2]) {
239	!	c1 <- c(c1, "Information saturated (h1) model")
240	!	tmp.txt <- h1.information[2]
241	!	c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
242	!	substring(tmp.txt, 2),
243	!	sep = ""
244		))
245	!	c3 <- c(c3, "")
246		}
247		# if observed.information type is different from 'se', print it
248	20x	if (length(observed.information) > 1L &&
249	20x	information[2] == "observed" &&
250	20x	(observed.information[1] !=
251	20x	observed.information[2])) {
252	!	c1 <- c(c1, "Observed information based on")
253	!	tmp.txt <- observed.information[2]
254	!	c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
255	!	substring(tmp.txt, 2),
256	!	sep = ""
257		))
258	!	c3 <- c(c3, "")
259		}
260
261
262		# format c1/c2/c3 (note: fitMeasures uses 35/16/8)
263	20x	c1 <- format(c1, width = 43L)
264	20x	c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right")
265	20x	c3 <- format(c3, width = 8L + nd, justify = "right")
266
267		# create character matrix
268	20x	if (twocolumn) {
269	2x	M <- cbind(c1, c2, c3, deparse.level = 0)
270		} else {
271	18x	M <- cbind(c1, c2, deparse.level = 0)
272		}
273	20x	colnames(M) <- rep("", ncol(M))
274	20x	rownames(M) <- rep(" ", nrow(M))
275
276		# print
277	20x	write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
278
279		# multiple groups?
280	20x	ngroups <- ngroups
281	20x	if (ngroups > 1L && !is.null(TEST[[block]]$stat.group)) {
282	2x	c1 <- c2 <- c3 <- character(ngroups)
283	2x	for (g in 1:ngroups) {
284	4x	tmp <- sprintf(" %-40s", group.label[[g]])
285	4x	c1[g] <- format(tmp, width = 43L)
286	4x	if (!twocolumn) {
287	4x	tmp <- sprintf(num.format, TEST[[block]]$stat.group[g])
288	4x	c2[g] <- format(tmp,
289	4x	width = 8L + max(0, (nd - 3L)) * 4L,
290	4x	justify = "right"
291		)
292		} else {
293	!	tmp <- sprintf(num.format, TEST[[block]]$stat.group[g])
294	!	c2[g] <- format(tmp,
295	!	width = 8L + max(0, (nd - 3L)) * 4L,
296	!	justify = "right"
297		)
298	!	tmp <- sprintf(num.format, TEST[[block]]$stat.group[g])
299	!	c3[g] <- format(tmp, width = 8L + nd, justify = "right")
300		}
301		}
302	2x	if (twocolumn) {
303	!	M <- cbind(c1, c2, c3, deparse.level = 0)
304		} else {
305	2x	M <- cbind(c1, c2, deparse.level = 0)
306		}
307	2x	colnames(M) <- rep("", ncol(M))
308	2x	rownames(M) <- rep(" ", nrow(M))
309	2x	cat(" Test statistic for each group:\n")
310	2x	write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)
311		}
312		} # blocks
313
314		# invisible(M)
315		}

1		lav_lavaan_step04_partable <- function(slotParTable = NULL, # nolint
2		model = NULL,
3		flat.model = NULL,
4		lavoptions = NULL,
5		lavdata = NULL,
6		constraints = NULL) {
7		# # # # # # # # # # # #
8		# # 4. lavpartable # #
9		# # # # # # # # # # # #
10
11		# if slotParTable not null
12		# copy slotParTable to lavpartable
13		# else
14		# if model is character or formula
15		# create a temporary variable tmp.data.ov equal to lavdata@ov
16		# if estimator "catML"
17		# set meanstructure to FALSE
18		# set the member type in the temporary variable tmp.data.ov to a
19		# numeric vector with all zeroes
20		# create lavpartable via function lavParTable (=lav_model_partable)
21		# using the temporary variable for parameter varTable
22		# else
23		# if model is lavaan object
24		# set lavpartable = parTable(model)
25		# else
26		# if model is a list
27		# set lavpartable to
28		# as.list(lav_partable_complete(as.list(flat.model)))
29		# else
30		# * error *
31		# if slotParTable is NULL check lavpartable via lav_partable_check
32		# if lavoptions$optim.method is "em" and there are variances specified in
33		# partable with free = 0L and
34		# starting value ustart 0, set ustart for these variances to
35		# lavoptions$em.zerovar.offset
36
37	140x	if (!is.null(slotParTable)) {
38	!	lavpartable <- lav_partable_set_cache(slotParTable)
39	140x	} else if (is.character(model) \|\|
40	140x	inherits(model, "formula") \|\|
41		# model was already a flat.model
42	140x	(is.list(model) && !is.null(model$mod.idx) &&
43	140x	!is.null(attr(model, "modifiers")))) {
44	47x	if (lav_verbose()) {
45	!	cat("lavpartable ...")
46		}
47		# check flat.model before we proceed
48	47x	if (lav_debug()) {
49	!	print(as.data.frame(flat.model))
50		}
51		# catch ~~ of fixed.x covariates if fixed.x = TRUE
52		# --> done inside lav_model_partable!
53
54		# if(lavoptions$fixed.x) {
55		# tmp <- lav_partable_vnames(flat.model, type = "ov.x",
56		# ov.x.fatal = FALSE, warn = TRUE)
57		# tmp <- try(lav_partable_vnames(flat.model, type = "ov.x",
58		# ov.x.fatal = TRUE),
59		# silent = TRUE)
60		# if(inherits(tmp, "try-error")) {
61		# warning("lavaan WARNING: syntax contains parameters involving ",
62		# "exogenous covariates; switching to fixed.x = FALSE")
63		# lavoptions$fixed.x <- FALSE
64		# }
65		# }
66		# if(lavoptions$conditional.x) {
67		# tmp <- lav_partable_vnames(flat.model, type = "ov.x", ov.x.fatal = TRUE)
68		# }
69	47x	tmp.data.ov <- lavdata@ov
70	47x	if (lavoptions$estimator == "catML") {
71	!	lavoptions$meanstructure <- FALSE
72	!	tmp.data.ov$type <- rep("numeric", length(tmp.data.ov$type))
73		}
74	47x	lavpartable <-
75	47x	lavParTable(
76	47x	model = flat.model,
77	47x	constraints = constraints,
78	47x	varTable = tmp.data.ov,
79	47x	ngroups = lavdata@ngroups,
80	47x	meanstructure = lavoptions$meanstructure,
81	47x	int.ov.free = lavoptions$int.ov.free,
82	47x	int.lv.free = lavoptions$int.lv.free,
83	47x	marker.int.zero = lavoptions$marker.int.zero,
84	47x	orthogonal = lavoptions$orthogonal,
85	47x	orthogonal.x = lavoptions$orthogonal.x,
86	47x	orthogonal.y = lavoptions$orthogonal.y,
87	47x	orthogonal.efa = lavoptions$rotation.args$orthogonal,
88	47x	conditional.x = lavoptions$conditional.x,
89	47x	fixed.x = lavoptions$fixed.x,
90	47x	std.lv = lavoptions$std.lv,
91	47x	correlation = lavoptions$correlation,
92	47x	composites = lavoptions$composites,
93	47x	effect.coding = lavoptions$effect.coding,
94	47x	ceq.simple = lavoptions$ceq.simple,
95	47x	parameterization = lavoptions$parameterization,
96	47x	auto.fix.first = lavoptions$auto.fix.first,
97	47x	auto.fix.single = lavoptions$auto.fix.single,
98	47x	auto.var = lavoptions$auto.var,
99	47x	auto.cov.lv.x = lavoptions$auto.cov.lv.x,
100	47x	auto.cov.y = lavoptions$auto.cov.y,
101	47x	auto.th = lavoptions$auto.th,
102	47x	auto.delta = lavoptions$auto.delta,
103	47x	auto.efa = lavoptions$auto.efa,
104	47x	group.equal = lavoptions$group.equal,
105	47x	group.partial = lavoptions$group.partial,
106	47x	group.w.free = lavoptions$group.w.free,
107	47x	as.data.frame. = FALSE
108		)
109	47x	lavpartable <- lav_partable_set_cache(lavpartable)
110	47x	if (lav_verbose()) {
111	!	cat(" done.\n")
112		}
113	93x	} else if (inherits(model, "lavaan")) {
114	!	lavpartable <- lav_partable_set_cache(as.list(parTable(model)), model@pta)
115	93x	} else if (is.list(model)) {
116		# we already checked this when creating flat.model
117		# but we may need to complete it
118	93x	lavpartable <- as.list(flat.model) # in case model is a data.frame
119		# complete table
120	93x	lavpartable <- as.list(lav_partable_complete(lavpartable))
121	93x	lavpartable <- lav_partable_set_cache(lavpartable)
122		} else {
123	!	lav_msg_stop(gettextf(
124	!	"model [type = %s] is not of type character or list", class(model)))
125		}
126	140x	if (lav_debug()) {
127	!	print(as.data.frame(lavpartable))
128		}
129
130		# at this point, we should check if the partable is complete
131		# or not; this is especially relevant if the lavaan() function
132		# was used, but the user has forgotten some variances/intercepts...
133	140x	if (is.null(slotParTable)) {
134	140x	junk <- lav_partable_check(lavpartable,
135	140x	categorical = lavoptions$.categorical
136		)
137	140x	rm(junk)
138		}
139
140		# for EM only (for now), force fixed-to-zero (residual) variances
141		# to be slightly larger than zero
142	140x	if (lavoptions$optim.method == "em") {
143	!	zero.var.idx <- which(lavpartable$op == "~~" &
144	!	lavpartable$lhs == lavpartable$rhs &
145	!	lavpartable$free == 0L &
146	!	lavpartable$ustart == 0)
147	!	if (length(zero.var.idx) > 0L) {
148	!	lavpartable$ustart[zero.var.idx] <- lavoptions$em.zerovar.offset
149		}
150	!	lavpartable <- lav_partable_set_cache(lavpartable, NULL, force = TRUE)
151		}
152
153	140x	list(
154	140x	lavoptions = lavoptions,
155	140x	lavpartable = lavpartable
156		)
157		}

1		# constrained optimization
2		# - references: * Nocedal & Wright (2006) Chapter 17
3		# * Optimization with constraints by Madsen, Nielsen & Tingleff
4		# * original papers: Powell, 1969 and Rockafeller, 1974
5		# - using 'nlminb' for the unconstrained subproblem
6		# - convergence scheme is based on the auglag function in the alabama package
7		nlminb.constr <- function(start, objective, gradient = NULL, hessian = NULL,
8		..., scale = 1, control = list(),
9		lower = -Inf, upper = Inf,
10		ceq = NULL, ceq.jac = NULL,
11		cin = NULL, cin.jac = NULL,
12		control.outer = list()) {
13		# we need a gradient
14	2x	stopifnot(!is.null(gradient))
15
16		# if no 'ceq' or 'cin' function, we create a dummy one
17	2x	if (is.null(ceq)) {
18	2x	ceq <- function(x, ...) {
19	3950x	return(numeric(0))
20		}
21		}
22	2x	if (is.null(cin)) {
23	!	cin <- function(x, ...) {
24	!	return(numeric(0))
25		}
26		}
27
28		# if no user-supplied jacobian functions, create them
29	2x	if (is.null(ceq.jac)) {
30	2x	if (is.null(ceq)) {
31	!	ceq.jac <- function(x, ...) {
32	!	matrix(0, nrow = 0L, ncol = length(x))
33		}
34		} else {
35	2x	ceq.jac <- function(x, ...) {
36	110x	numDeriv::jacobian(func = ceq, x = x, ...)
37		}
38		}
39		}
40	2x	if (is.null(cin.jac)) {
41	2x	if (is.null(cin)) {
42	!	cin.jac <- function(x, ...) {
43	!	matrix(0, nrow = 0L, ncol = length(x))
44		}
45		} else {
46	2x	cin.jac <- function(x, ...) {
47	110x	numDeriv::jacobian(func = cin, x = x, ...)
48		}
49		}
50		}
51
52		# how many ceq and cin constraints?
53	2x	nceq <- length(ceq(start))
54	2x	ncin <- length(cin(start))
55	2x	ncon <- nceq + ncin
56	2x	ceq.idx <- cin.idx <- integer(0)
57	!	if (nceq > 0L) ceq.idx <- 1:nceq
58	2x	if (ncin > 0L) cin.idx <- nceq + 1:ncin
59	2x	cin.flag <- rep(FALSE, length(ncon))
60	2x	if (ncin > 0L) cin.flag[cin.idx] <- TRUE
61
62		# control outer default values
63	2x	control.outer.default <- list(
64	2x	mu0 = 100,
65	2x	lambda0 = 10,
66	2x	tol = 1e-06, # changed this in 0.4-12
67	2x	itmax = 100L,
68	2x	verbose = FALSE
69		)
70	2x	control.outer <- modifyList(control.outer.default, control.outer)
71
72
73		# construct augmented lagrangian function
74	2x	auglag <- function(x, ...) {
75		# apply constraints
76	200x	ceq0 <- ceq(x, ...)
77	200x	cin0 <- cin(x, ...)
78	200x	con0 <- c(ceq0, cin0)
79		# 'release' inactive constraints
80	200x	if (ncin > 0L) {
81	200x	slack <- lambda / mu
82	200x	inactive.idx <- which(cin.flag & con0 > slack)
83	200x	con0[inactive.idx] <- slack[inactive.idx]
84		}
85	200x	objective(x, ...) - sum(lambda * con0) + (mu / 2) * sum(con0 * con0)
86		}
87
88	2x	fgrad <- function(x, ...) {
89		# apply constraints
90	108x	ceq0 <- ceq(x, ...)
91	108x	cin0 <- cin(x, ...)
92	108x	con0 <- c(ceq0, cin0)
93		# jacobian
94	108x	JAC <- rbind(ceq.jac(x, ...), cin.jac(x, ...))
95	108x	lambda.JAC <- lambda * JAC
96
97		# handle inactive constraints
98	108x	if (ncin > 0L) {
99	108x	slack <- lambda / mu
100	108x	inactive.idx <- which(cin.flag & con0 > slack)
101	108x	if (length(inactive.idx) > 0L) {
102	108x	JAC <- JAC[-inactive.idx, , drop = FALSE]
103	108x	lambda.JAC <- lambda.JAC[-inactive.idx, , drop = FALSE]
104	108x	con0 <- con0[-inactive.idx]
105		}
106		}
107
108	108x	if (nrow(JAC) > 0L) {
109	48x	(gradient(x, ...) - colSums(lambda.JAC) +
110	48x	mu * as.numeric(t(JAC) %*% con0))
111		} else {
112	60x	gradient(x, ...)
113		}
114		}
115
116
117		# initialization
118	2x	ceq0 <- ceq(start, ...)
119	2x	cin0 <- cin(start, ...)
120	2x	con0 <- c(ceq0, cin0)
121	2x	lambda <- rep(control.outer$lambda0, length(con0))
122	2x	mu <- control.outer$mu0
123	2x	inactive.idx <- integer(0)
124	2x	if (ncin > 0L) {
125	2x	slack <- lambda / mu
126	2x	inactive.idx <- which(cin.flag & con0 > slack)
127	2x	con0[inactive.idx] <- slack[inactive.idx]
128		}
129	2x	K <- max(abs(con0))
130	2x	if (control.outer$verbose) {
131	!	cat("init cin0 values: ", cin0, "\n")
132	!	cat("init ceq0 values: ", ceq0, "\n")
133	!	cat("init slack values: ", lambda / mu, "\n")
134	!	cat("init inactive idx: ", inactive.idx, "\n")
135	!	cat("init con0 values: ", con0, "\n")
136	!	cat("K = max con0: ", K, "\n")
137		}
138
139	2x	r <- obj <- objective(start, ...)
140	2x	feval <- 0L
141	2x	geval <- 0L
142	2x	niter <- 0L
143	2x	ilack <- 0L
144	2x	Kprev <- K
145	2x	mu0 <- control.outer$mu0 / Kprev
146	!	if (is.infinite(mu0)) mu0 <- 1.0
147	2x	mu <- mu0
148
149	2x	K <- Inf
150	2x	x.par <- start
151	2x	for (i in 1:control.outer$itmax) {
152	6x	x.old <- x.par
153	6x	r.old <- r
154		############################################################
155	6x	if (control.outer$verbose) {
156	!	cat("\nStarting inner optimization [", i, "]:\n")
157	!	cat("lambda: ", lambda, "\n")
158	!	cat("mu: ", mu, "\n")
159		}
160	6x	optim.out <- nlminb(
161	6x	start = x.par, objective = auglag,
162	6x	gradient = fgrad, control = control,
163	6x	lower = lower, upper = upper,
164	6x	scale = scale, ...
165		)
166		############################################################
167	6x	x.par <- optim.out$par
168	6x	r <- optim.out$objective
169	6x	feval <- feval + optim.out$evaluations[1]
170	6x	geval <- geval + optim.out$evaluations[2]
171	6x	niter <- niter + optim.out$iterations
172
173		# check constraints
174	6x	ceq0 <- ceq(x.par, ...)
175	6x	cin0 <- cin(x.par, ...)
176	6x	con0 <- c(ceq0, cin0)
177	6x	if (ncin > 0L) {
178	6x	slack <- lambda / mu
179	6x	inactive.idx <- which(cin.flag & con0 > slack)
180	6x	con0[inactive.idx] <- slack[inactive.idx]
181		}
182	6x	K <- max(abs(con0))
183	6x	if (control.outer$verbose) {
184	!	cat("cin0 values: ", cin0, "\n")
185	!	cat("ceq0 values: ", ceq0, "\n")
186	!	cat("active threshold: ", lambda / mu, "\n")
187	!	cat("inactive idx: ", inactive.idx, "\n")
188	!	cat("con0 values: ", con0, "\n")
189	!	cat("K = max con0: ", K, " Kprev = ", Kprev, "\n")
190		}
191
192		# update K or mu (see Powell, 1969)
193	6x	if (K <= Kprev / 4) {
194	6x	lambda <- lambda - (mu * con0)
195	6x	Kprev <- K
196		} else {
197	!	mu <- 10 * mu
198		}
199
200		# check convergence
201	6x	pconv <- max(abs(x.par - x.old))
202	6x	if (pconv < control.outer$tol) {
203	!	ilack <- ilack + 1L
204		} else {
205	6x	ilack <- 0L
206		}
207
208	6x	if ((is.finite(r) && is.finite(r.old) &&
209	6x	abs(r - r.old) < control.outer$tol && K < control.outer$tol) \|
210	6x	ilack >= 3) {
211	2x	break
212		}
213		}
214
215		# output
216	2x	a <- list()
217
218	2x	if (i == control.outer$itmax) {
219	!	a$convergence <- 10L
220	!	a$message <- "nlminb.constr ran out of iterations and did not converge"
221	2x	} else if (K > control.outer$tol) {
222	!	a$convergence <- 11L
223	!	a$message <- "Convergence due to lack of progress in parameter updates"
224		} else {
225	2x	a$convergence <- 0L
226	2x	a$message <- "converged"
227		}
228	2x	a$par <- optim.out$par
229	2x	a$outer.iterations <- i
230	2x	a$lambda <- lambda
231	2x	a$mu <- mu
232		# a$value <- objective(a$start, ...)
233		# a$cin <- cin(a$start, ...)
234		# a$ceq <- ceq(a$start, ...)
235	2x	a$evaluations <- c(feval, geval)
236	2x	a$iterations <- niter
237		# a$kkt1 <- max(abs(a$fgrad)) <= 0.01 * (1 + abs(a$value))
238		# a$kkt2 <- any(eigen(a$hessian)$value * control.optim$objectivescale> 0)
239
240		# jacobian of ceq and 'active' cin
241	2x	ceq0 <- ceq(a$par, ...)
242	2x	cin0 <- cin(a$par, ...)
243	2x	con0 <- c(ceq0, cin0)
244	2x	JAC <- rbind(ceq.jac(a$par, ...), cin.jac(a$par, ...))
245	2x	inactive.idx <- integer(0L)
246	2x	cin.idx <- which(cin.flag)
247		# ceq.idx <- which(!cin.flag)
248	2x	if (ncin > 0L) {
249		# FIXME: slack value not too strict??
250	2x	slack <- 1e-05
251		# cat("DEBUG:\n"); print(con0)
252	2x	inactive.idx <- which(cin.flag & abs(con0) > slack)
253		# if(length(inactive.idx) > 0L) {
254		# JAC <- JAC[-inactive.idx,,drop=FALSE]
255		# }
256		}
257	2x	attr(JAC, "inactive.idx") <- inactive.idx
258	2x	attr(JAC, "cin.idx") <- cin.idx
259	2x	attr(JAC, "ceq.idx") <- ceq.idx
260	2x	a$con.jac <- JAC
261
262	2x	a
263		}

1		lav_lavaan_step02_options <- function(slotOptions = NULL, # nolint
2		slotData = NULL, # nolint
3		flat.model = NULL,
4		ordered = NULL,
5		sample.cov = NULL,
6		sample.mean = NULL,
7		sample.th = NULL,
8		sample.nobs = NULL,
9		ov.names.l = NULL,
10		sampling.weights = NULL,
11		constraints = NULL,
12		group = NULL,
13		ov.names.x = NULL,
14		ov.names.y = NULL,
15		dotdotdot = NULL,
16		cluster = NULL,
17		data = NULL) {
18		# # # # # # # # # # # #
19		# # 2. lavoptions # #
20		# # # # # # # # # # # #
21
22		# if slotOptions not NULL
23		# copy to lavoptions and modify categorical/clustered/multilevel
24		# inserting a "." in the first position
25		# if necessary, overwrite with values in dotdotdot and issue a warning
26		# check if all names in dotdotdot are possible options, if not * error *
27		# create complete option list (lav_options_default) and substitute values
28		# given in dotdotdot
29		# if data, slotData and sample.cov NULL: opt$bounds = FALSE
30		# if slotData$data.type != "full" or (slotData and data = NULL):
31		# opt$missing = "listwise"
32		# set categorical mode ON if
33		# - an operator "\|" (threshold) was used
34		# - data not NULL and one or more elements in ordered parameter
35		# - sample.th provided
36		# - at least one of the non-exogenous observed variables is "ordered"
37		# (ordered factor in R)
38		# if opt$estimator == "catml": set categorical mode OFF
39		# TODO: estimator = "CATML" isn't mentioned in lavOptions / estimator
40		# help text !?
41		# if cluster not NULL, set opt$.clustered TRUE and * error * if
42		# categorical mode is ON
43		# opt$.multilevel = (length(ov.names.l) > 0L &&
44		# length(ov.names.l[[1]]) > 1L)
45		# if sampling.weights not NULL en categorical mode OFF and opt$estimator
46		# in ("default", "ML", "PML")
47		# set opt$estimator to "MLR"
48		# if constraints present and estimator == "ML", set opt$information to
49		# c("observed", "observed")
50		# if there is an operator "~1" in flat.model and sample.mean not NULL,
51		# set opt$meanstructure TRUE
52		# if there are no exogenous variables but conditional.x explicitly
53		# requested: warning
54		# if there are no exogenous variables set opt$conditional.x FALSE
55		# if there are no exogenous variables and fixed.x not explicitly requested,
56		# set opt$fixed.x to FALSE
57		# if allow.empty.cell and estimator not Bayes, issue a warning
58
59	140x	if (!is.null(slotOptions)) {
60	61x	lavoptions <- slotOptions
61
62		# backwards compatibility
63	61x	if (!is.null(lavoptions$categorical)) {
64	61x	lavoptions$.categorical <- lavoptions$categorical
65	61x	lavoptions$categorical <- NULL
66		}
67	61x	if (!is.null(lavoptions$clustered)) {
68	!	lavoptions$.clustered <- lavoptions$clustered
69	!	lavoptions$clustered <- NULL
70		}
71	61x	if (!is.null(lavoptions$multilevel)) {
72	!	lavoptions$.multilevel <- lavoptions$multilevel
73	!	lavoptions$multilevel <- NULL
74		}
75
76		# but what if other 'options' are given anyway (eg 'start = ')?
77		# give a warning!
78	61x	if (length(dotdotdot) > 0L) {
79	!	dot.names <- names(dotdotdot)
80	!	op.idx <- which(dot.names %in% names(slotOptions))
81	!	lav_msg_warn(gettext(
82	!	"the following argument(s) override(s) the options in slotOptions:"),
83	!	paste(dot.names[op.idx], collapse = " ")
84		)
85	!	lavoptions[dot.names[op.idx]] <- dotdotdot[op.idx]
86		}
87		} else {
88	79x	if (lav_verbose()) {
89	!	cat("lavoptions ...")
90		}
91
92		# load default options
93	79x	opt <- lav_options_default()
94
95		# catch unknown options
96	79x	ok.names <- names(opt)
97	79x	dot.names <- names(dotdotdot)
98	79x	wrong.idx <- which(!dot.names %in% ok.names)
99	79x	if (length(wrong.idx) > 0L) {
100		# stop or warning?? stop for now (there could be more)
101	!	lav_msg_stop(ngettext(length(wrong.idx),
102	!	"unknown argument:", "unknown arguments:"),
103	!	lav_msg_view(dot.names[wrong.idx], "none", FALSE)
104		)
105		}
106
107		# modifyList
108	79x	opt <- modifyList(opt, dotdotdot)
109
110		# extract estimator
111	79x	if (is.list(opt$estimator)) {
112	!	estimator <- opt$estimator$estimator
113		} else {
114	79x	estimator <- opt$estimator
115		}
116
117		# no data?
118	79x	if (is.null(slotData) && is.null(data) && is.null(sample.cov)) {
119	2x	opt$bounds <- FALSE
120		}
121
122		# only sample moments?
123	79x	if (!is.null(slotData) && !slotData@data.type == "full") {
124	!	opt$missing <- "listwise"
125	79x	} else if (is.null(slotData) && is.null(data)) {
126	44x	opt$missing <- "listwise"
127		}
128
129		# categorical mode?
130	79x	opt$.categorical <- FALSE
131	79x	if (any(flat.model$op == "\|")) {
132	!	opt$.categorical <- TRUE
133	79x	} else if (!is.null(data) && length(ordered) > 0L) {
134	2x	opt$.categorical <- TRUE
135	77x	} else if (!is.null(sample.th)) {
136	!	opt$.categorical <- TRUE
137	77x	} else if (is.data.frame(data)) {
138		# first check if we can find ov.names.y in Data
139	33x	tmp.ov.names.y <- unique(unlist(ov.names.y))
140		# remove possible interaction terms involving an y term
141	33x	int.idx <- which(grepl(":", tmp.ov.names.y))
142	33x	if (length(int.idx) > 0L) {
143	!	tmp.ov.names.y <- tmp.ov.names.y[-int.idx]
144		}
145	33x	idx.missing <- which(!(tmp.ov.names.y %in% names(data)))
146	33x	if (length(idx.missing)) {
147	!	lav_msg_stop(
148	!	gettext("missing observed variables in dataset:"),
149	!	paste(tmp.ov.names.y[idx.missing], collapse = " ")
150		)
151		}
152	33x	if (any(sapply(data[, tmp.ov.names.y], inherits, "ordered"))) {
153	!	opt$.categorical <- TRUE
154		}
155		}
156	79x	if (tolower(estimator) == "catml") {
157	!	opt$.categorical <- FALSE
158		}
159
160		# clustered?
161	79x	if (length(cluster) > 0L) {
162	2x	opt$.clustered <- TRUE
163	2x	if (opt$.categorical && toupper(estimator) != "PML") {
164	!	lav_msg_stop(gettext("categorical + clustered is not supported yet."))
165		}
166		} else {
167	77x	opt$.clustered <- FALSE
168		}
169
170		# multilevel?
171	79x	if (length(ov.names.l) > 0L && length(ov.names.l[[1]]) > 1L) {
172	2x	opt$.multilevel <- TRUE
173		} else {
174	77x	opt$.multilevel <- FALSE
175		}
176
177		# sampling weights? force MLR
178		# HJ 18/10/23: Except for PML
179	79x	if (!is.null(sampling.weights) && !opt$.categorical &&
180	79x	toupper(estimator) %in% c("DEFAULT", "ML", "PML")) {
181	!	if (opt$se != "none") {
182	!	opt$se <- "robust.huber.white"
183		}
184	!	if (opt$se != "none") {
185	!	opt$test <- "yuan.bentler.mplus"
186		}
187		}
188
189		# constraints
190	79x	if (any(nchar(constraints) > 0L) && toupper(estimator) %in% c("ML")) {
191	!	opt$information <- c("observed", "observed")
192		}
193
194		# meanstructure
195	79x	if (any(flat.model$op == "~1") \|\| !is.null(sample.mean)) {
196	40x	opt$meanstructure <- TRUE
197		}
198	79x	if (!is.null(group) && is.null(dotdotdot$meanstructure)) {
199	2x	opt$meanstructure <- TRUE
200		}
201
202		# conditional.x
203	79x	if ((is.list(ov.names.x) &&
204	79x	sum(sapply(ov.names.x, FUN = length)) == 0L) \|\|
205	79x	(is.character(ov.names.x) && length(ov.names.x) == 0L)) {
206		# if explicitly set to TRUE, give warning
207	39x	if (is.logical(dotdotdot$conditional.x) && dotdotdot$conditional.x) {
208	!	lav_msg_warn(
209	!	gettext("no exogenous covariates; conditional.x will be set to FALSE"))
210		}
211	39x	opt$conditional.x <- FALSE
212		}
213
214		# fixed.x
215	79x	if ((is.list(ov.names.x) &&
216	79x	sum(sapply(ov.names.x, FUN = length)) == 0L) \|\|
217	79x	(is.character(ov.names.x) && length(ov.names.x) == 0L)) {
218		# if explicitly set to TRUE, give warning
219	39x	if (is.logical(dotdotdot$fixed.x) && dotdotdot$fixed.x) {
220		# ok, we respect this: keep fixed.x = TRUE
221		} else {
222	39x	opt$fixed.x <- FALSE
223		}
224		}
225
226		# allow.empty.cell
227	79x	if (opt$allow.empty.cell && opt$do.fit && toupper(estimator) != "BAYES") {
228	!	lav_msg_warn(
229	!	gettext("allow.empty.cell is not intended to salvage estimation of this model, see ?lavOptions"))
230		}
231
232		# fill in remaining "default" values
233	79x	lavoptions <- lav_options_set(opt)
234
235		# store check.sigma.pd in lavaan_cache_env
236	79x	assign("opt.check.sigma.pd", opt$check.sigma.pd, lavaan_cache_env)
237
238	79x	if (lav_verbose()) {
239	!	cat(" done.\n")
240		}
241		}
242
243	140x	lavoptions
244		}

1		# This file will (eventually) contain functions that can be used to
2		# 'predict' the values of outcome variables (y), given the values of
3		# input variables (x).
4
5		# first version YR 2 Nov 2022
6
7		# method = "conditional.mean" is based on the following article:
8
9		# Mark de Rooij, Julian D. Karch, Marjolein Fokkema, Zsuzsa Bakk, Bunga Citra
10		# Pratiwi & Henk Kelderman (2022) SEM-Based Out-of-Sample Predictions,
11		# StructuralEquation Modeling: A Multidisciplinary Journal
12		# DOI:10.1080/10705511.2022.2061494
13
14		# YR 31 Jan 2023: we always 'force' meanstructure = TRUE (for now)
15
16		# main function
17		lavPredictY <- function(object,
18		newdata = NULL,
19		ynames = lav_object_vnames(object, "ov.y"),
20		xnames = lav_object_vnames(object, "ov.x"),
21		method = "conditional.mean",
22		label = TRUE,
23		assemble = TRUE,
24		force.zero.mean = FALSE,
25		lambda = 0) {
26	!	stopifnot(inherits(object, "lavaan"))
27		# check object
28	!	object <- lav_object_check_version(object)
29
30	!	lavmodel <- object@Model
31	!	lavdata <- object@Data
32	!	lavimplied <- object@implied
33
34		# check meanstructure
35	!	if (!lavmodel@meanstructure) {
36	!	lavimplied$mean <- lapply(object@SampleStats@mean, as.matrix)
37		}
38
39		# need full data set
40	!	if (is.null(newdata)) {
41		# use internal copy:
42	!	if (lavdata@data.type != "full") {
43	!	lav_msg_stop(gettext(
44	!	"sample statistics were used for fitting and newdata is empty"
45		))
46	!	} else if (is.null(lavdata@X[[1]])) {
47	!	lav_msg_stop(gettext("no local copy of data; FIXME!"))
48		} else {
49	!	data.obs <- lavdata@X
50	!	ov.names <- lavdata@ov.names
51		}
52		# eXo <- lavdata@eXo
53		} else {
54		# newdata is given!
55
56		# create lavData object
57	!	OV <- lavdata@ov
58	!	newData <- lav_lavdata(
59	!	data = newdata,
60	!	group = lavdata@group,
61	!	ov.names = lavdata@ov.names,
62	!	ov.names.x = lavdata@ov.names.x,
63	!	ordered = OV$name[OV$type == "ordered"],
64	!	lavoptions = list(
65	!	std.ov = lavdata@std.ov,
66	!	group.label = lavdata@group.label,
67	!	missing = "ml.x", # always!
68	!	warn = TRUE
69		),
70	!	allow.single.case = TRUE
71		)
72		# if ordered, check if number of levels is still the same (new in 0.6-7)
73	!	if (lavmodel@categorical) {
74	!	orig.ordered.idx <- which(lavdata@ov$type == "ordered")
75	!	orig.ordered.lev <- lavdata@ov$nlev[orig.ordered.idx]
76	!	match.new.idx <- match(
77	!	lavdata@ov$name[orig.ordered.idx],
78	!	newData@ov$name
79		)
80	!	new.ordered.lev <- newData@ov$nlev[match.new.idx]
81	!	if (any(orig.ordered.lev - new.ordered.lev != 0)) {
82	!	lav_msg_stop(gettext(
83	!	"mismatch number of categories for some ordered variables in
84	!	newdata compared to original data."
85		))
86		}
87		}
88
89	!	data.obs <- newData@X
90		# eXo <- newData@eXo
91	!	ov.names <- newData@ov.names
92		} # newdata
93
94		# check ynames
95	!	if (length(ynames) == 0L) {
96	!	lav_msg_stop(gettext(
97	!	"please specify the y-variables in the ynames= argument"
98		))
99		}
100
101	!	if (anyDuplicated((ynames))) {
102	!	lav_msg_stop(gettext(
103	!	"ynames contains duplicate variable names"
104		))
105		}
106
107	!	if (!is.list(ynames)) {
108	!	ynames <- rep(list(ynames), lavdata@ngroups)
109		}
110
111		# check xnames
112	!	if (length(xnames) == 0L) {
113	!	lav_msg_stop(gettext(
114	!	"please specify the x-variables in the xnames= argument"
115		))
116		}
117
118	!	if (anyDuplicated((xnames))) {
119	!	lav_msg_stop(gettext(
120	!	"ynames contains duplicate variable names"
121		))
122		}
123
124	!	if (!is.list(xnames)) {
125	!	xnames <- rep(list(xnames), lavdata@ngroups)
126		}
127
128		# create y.idx and x.idx
129	!	y.idx <- x.idx <- vector("list", lavdata@ngroups)
130	!	for (g in seq_len(lavdata@ngroups)) {
131		# ynames in ov.names for this group?
132	!	missing.idx <- which(!ynames[[g]] %in% ov.names[[g]])
133	!	if (length(missing.idx) > 0L) {
134	!	lav_msg_stop(
135	!	gettext(
136	!	"some variable names in ynames do not appear in the dataset:"
137		),
138	!	lav_msg_view(ynames[[g]][missing.idx], "none")
139		)
140		} else {
141	!	y.idx[[g]] <- match(ynames[[g]], ov.names[[g]])
142		}
143
144		# xnames in ov.names for this group?
145	!	missing.idx <- which(!xnames[[g]] %in% ov.names[[g]])
146	!	if (length(missing.idx) > 0L) {
147	!	lav_msg_stop(
148	!	gettext(
149	!	"some variable names in xnames do not appear in the dataset:"
150		),
151	!	lav_msg_view(xnames[[g]][missing.idx], "none")
152		)
153		} else {
154	!	x.idx[[g]] <- match(xnames[[g]], ov.names[[g]])
155		}
156		}
157
158		# prediction method
159	!	method <- tolower(method)
160	!	if (method == "conditional.mean") {
161	!	out <- lav_predict_y_conditional_mean(
162	!	lavobject = NULL,
163	!	lavmodel = lavmodel, lavdata = lavdata,
164	!	lavimplied = lavimplied,
165	!	data.obs = data.obs, y.idx = y.idx, x.idx = x.idx,
166	!	force.zero.mean = force.zero.mean,
167	!	lambda = lambda
168		)
169		} else {
170	!	lav_msg_stop(gettext("method must be \"conditional.mean\" (for now)."))
171		}
172
173		# label?
174	!	if (label) {
175		# column names
176	!	for (g in seq_len(lavdata@ngroups)) {
177	!	colnames(out[[g]]) <- ynames[[g]]
178		}
179
180		# group.labels
181	!	if (lavdata@ngroups > 1L) {
182	!	names(out) <- lavdata@group.label
183		}
184		}
185
186		# lavaan.matrix
187	!	out <- lapply(out, "class<-", c("lavaan.matrix", "matrix"))
188
189	!	if (lavdata@ngroups == 1L) {
190	!	res <- out[[1L]]
191		} else {
192	!	res <- out
193		}
194
195		# assemble multiple groups into a single data.frame?
196	!	if (lavdata@ngroups > 1L && assemble) {
197	!	if (!is.null(newdata)) {
198	!	lavdata <- newData
199		}
200	!	DATA <- matrix(as.numeric(NA),
201	!	nrow = sum(unlist(lavdata@norig)),
202	!	ncol = ncol(out[[1L]])
203	!	) # assume == per g
204	!	colnames(DATA) <- colnames(out[[1L]])
205	!	for (g in seq_len(lavdata@ngroups)) {
206	!	DATA[lavdata@case.idx[[g]], ] <- out[[g]]
207		}
208	!	DATA <- as.data.frame(DATA, stringsAsFactors = FALSE)
209
210	!	if (!is.null(newdata)) {
211	!	DATA[, lavdata@group] <- newdata[, lavdata@group]
212		} else {
213		# add group
214	!	DATA[, lavdata@group] <- rep(as.character(NA), nrow(DATA))
215	!	if (lavdata@missing == "listwise") {
216		# we will loose the group label of omitted variables!
217	!	DATA[unlist(lavdata@case.idx), lavdata@group] <-
218	!	rep(lavdata@group.label, unlist(lavdata@nobs))
219		} else {
220	!	DATA[unlist(lavdata@case.idx), lavdata@group] <-
221	!	rep(lavdata@group.label, unlist(lavdata@norig))
222		}
223		}
224
225	!	res <- DATA
226		}
227
228	!	res
229		}
230
231
232		# method = "conditional.mean"
233		lav_predict_y_conditional_mean <- function(
234		lavobject = NULL, # for convenience
235		# object ingredients
236		lavmodel = NULL,
237		lavdata = NULL,
238		lavimplied = NULL,
239		# new data
240		data.obs = NULL,
241		# y and x
242		y.idx = NULL,
243		x.idx = NULL,
244		# options
245		force.zero.mean = FALSE,
246		lambda = lambda,
247		level = 1L) { # not used for now
248
249		# full object?
250	!	if (inherits(lavobject, "lavaan")) {
251	!	lavmodel <- lavobject@Model
252	!	lavdata <- lavobject@Data
253		# lavsamplestats <- lavobject@SampleStats
254	!	lavimplied <- lavobject@implied
255		} else {
256	!	stopifnot(
257	!	!is.null(lavmodel), !is.null(lavdata),
258		# !is.null(lavsamplestats),
259	!	!is.null(lavimplied)
260		)
261		}
262
263		# data.obs?
264	!	if (is.null(data.obs)) {
265	!	data.obs <- lavdata@X
266		}
267
268		# checks
269	!	if (lavmodel@categorical) {
270	!	lav_msg_stop(gettext("no support for categorical data (yet)."))
271		}
272	!	if (lavdata@nlevels > 1L) {
273	!	lav_msg_stop(gettext("no support for multilevel data (yet)."))
274		}
275
276		# conditional.x?
277	!	if (lavmodel@conditional.x) {
278	!	SigmaHat <- lav_model_cond2joint_sigma(lavmodel)
279	!	if (lavmodel@meanstructure) {
280	!	MuHat <- lav_model_cond2joint_mu(lavmodel)
281		}
282		} else {
283	!	SigmaHat <- lavimplied$cov
284	!	MuHat <- lavimplied$mean
285		}
286
287		# output container
288	!	YPRED <- vector("list", length = lavdata@ngroups)
289
290		# run over all groups
291	!	for (g in 1:lavdata@ngroups) {
292		# multiple levels?
293	!	if (lavdata@nlevels > 1L) {
294		# TODO!
295	!	lav_msg_stop(gettext("no support for multilevel data (yet)!"))
296		} else {
297	!	data.obs.g <- data.obs[[g]]
298
299		# model-implied variance-covariance matrix for this group
300	!	cov.g <- SigmaHat[[g]]
301
302		# model-implied mean vector for this group
303	!	if (force.zero.mean) {
304	!	mean.g <- rep(0, ncol(data.obs.g))
305		} else {
306	!	mean.g <- as.numeric(MuHat[[g]])
307		}
308
309		# indices (in ov.names)
310	!	y.idx.g <- y.idx[[g]]
311	!	x.idx.g <- x.idx[[g]]
312
313		# partition y/x
314	!	Sxx <- cov.g[x.idx.g, x.idx.g, drop = FALSE]
315	!	Sxy <- cov.g[x.idx.g, y.idx.g, drop = FALSE]
316
317		# x-data only
318	!	Xtest <- data.obs.g[, x.idx.g, drop = FALSE]
319
320		# mx/my
321	!	mx <- mean.g[x.idx.g]
322	!	my <- mean.g[y.idx.g]
323
324		# center using mx
325	!	Xtest <- t(t(Xtest) - mx)
326
327		# Apply regularization
328	!	Sxx <- Sxx + lambda * diag(nrow(Sxx))
329
330		# prediction rule
331	!	tmp <- Xtest %*% solve(Sxx, Sxy)
332	!	YPRED[[g]] <- t(t(tmp) + my)
333		} # single level
334		} # g
335
336	!	YPRED
337		}
338
339
340		# Takes a sequence of lambdas and performs k-fold cross-validation to determine
341		# the best lambda
342		lavPredictY_cv <- function(
343		object,
344		data = NULL,
345		xnames = lav_object_vnames(object, "ov.x"),
346		ynames = lav_object_vnames(object, "ov.y"),
347		n.folds = 10L,
348		lambda.seq = seq(0, 1, 0.1)) {
349
350		# object should be (or inherit from) a lavaan object
351	!	stopifnot(inherits(object, "lavaan"))
352		# check object
353	!	object <- lav_object_check_version(object)
354
355		# results container
356	!	results <- matrix(as.numeric(NA),
357	!	nrow = length(lambda.seq) * n.folds,
358	!	ncol = 2L
359		)
360	!	colnames(results) <- c("mse", "lambda")
361
362		# shuffle folds
363	!	folds <- sample(rep(1:n.folds, length.out = nrow(data)))
364
365		# extract Y-data
366	!	Y <- as.matrix(data[, ynames, drop = FALSE])
367
368	!	j <- 0L
369	!	for (i in 1:n.folds) {
370	!	indis <- which(folds == i)
371	!	fold.fit <- try(update(object,
372	!	data = data[-indis, , drop = FALSE],
373	!	warn = FALSE
374	!	), silent = TRUE)
375	!	if (inherits(fold.fit, "try-error")) {
376	!	lav_msg_warn(gettext("failed fit in fold %s", i))
377	!	next
378		}
379	!	for (l in lambda.seq) {
380	!	j <- j + 1L
381	!	yhat <- lavPredictY(
382	!	fold.fit,
383	!	newdata = data[indis, , drop = FALSE],
384	!	xnames = xnames,
385	!	ynames = ynames,
386	!	lambda = l
387		)
388	!	y.error <- Y[indis, , drop = FALSE] - yhat
389	!	mse <- mean(y.error * y.error)
390	!	results[j, ] <- c(mse, l)
391		}
392		}
393
394		# Group by lambda and determine average MSE per group
395	!	avg <- aggregate(results[, "mse"],
396	!	by = list(results[, "lambda"]),
397	!	FUN = mean, na.rm = TRUE
398		)
399	!	avg <- avg[order(avg[, 2]), ]
400	!	names(avg) <- c("lambda", "mse")
401	!	lambda.min <- avg[1L, "lambda"]
402
403	!	list(results = avg, lambda.min = lambda.min)
404		}

1		# SAM: a Structural After Measurement approach
2		#
3		# Yves Rosseel & Wen-Wei Loh, Feb-May 2019
4
5		# local vs global sam
6		# local sam = alternative for FSR+Croon
7		# - but no need to compute factor scores or corrections
8		# global sam = (old) twostep
9		# - but we can also take a 'local' perspective
10
11		# restrictions:
12		#
13		# local and global:
14		# - all (measured) latent variables must have indicators that are observed
15		# update: higher-order measurement models are supported in local SAM (0.6-20)
16		# local:
17		# - only if LAMBDA is of full column rank (eg no SRM, no bi-factor, no MTMM)
18		# - if multiple groups: each group has the same set of latent variables!
19		# - global approach is used to compute corrected two-step standard errors
20		# update: se = "local" is truely local, and uses 'Gamma' as an additional
21		# ingredient; Gamma reflects the sampling variability of the
22		# sample statistics (VETA and EETA)
23
24		# YR 12 May 2019 - first version
25		# YR 22 May 2019 - merge sam/twostep (call it 'local' vs 'global' sam)
26
27		# YR 27 June 2021 - prepare for `public' release
28		# - add Fuller (1987) 'lambda' correction if (MSM - MTM) is not
29		# positive definite
30		# - se = "none" now works
31		# - store 'local' information in @internal slot (for printing)
32
33		# YR 16 Oct 2021 - if an indicator is also a predictor/outcome in the
34		# structural part, treat it as an observed predictor
35		# without measurement error in the second step
36		# (ie, set THETA element to zero)
37
38		# YR 03 Dec 2022 - allow for sam.method = "fsr" and se = "naive"
39		# - add alpha.correction= argument (for small sample correction)
40
41		# YR 21 May 2023 - allow for latent quadratic/interaction terms in the
42		# structural part (assuming the errors are normal, for now)
43
44		# YR 25 May 2023 - restructure code into multiple files
45		# - rename veta.force.pd -> lambda.correction
46		# - move alpha.correction= argument to local.options
47
48		# YR 09 Nov 2024 - add se = "bootstrap"
49		# YR 14 Nov 2024 - add se = "local"
50		# YR 01 Mar 2025 - allow for higher-order measurement models in local SAM
51		# YR 25 Mar 2025 - add sam.method = "cFSR" (using correlation-preserving FS)
52		# YR 15 Apr 2025 - add se = "twostep.robust"
53
54		# twostep = wrapper for global sam
55		twostep <- function(model = NULL, data = NULL, cmd = "sem",
56		mm.list = NULL, mm.args = list(), struc.args = list(),
57		..., # global options
58		output = "lavaan") {
59	!	sam(
60	!	model = model, data = data, cmd = cmd, mm.list = mm.list,
61	!	mm.args = mm.args, struc.args = struc.args,
62	!	sam.method = "global", # or global
63	!	..., # global options
64	!	output = output
65		)
66		}
67
68		# fsr = wrapper for local sam
69		# TODO
70
71
72		sam <- function(model = NULL,
73		data = NULL,
74		cmd = "sem",
75		se = "twostep",
76		mm.list = NULL,
77		mm.args = list(bounds = "wide.zerovar"),
78		struc.args = list(estimator = "ML"),
79		sam.method = "local", # or "global", or "fsr", or "cfsr"
80		..., # common options
81		local.options = list(
82		M.method = "ML", # mapping matrix
83		lambda.correction = TRUE,
84		alpha.correction = 0L, # 0 -> (N-1)
85		twolevel.method = "h1"
86		),
87		# h1, anova, mean
88		global.options = list(), # not used for now
89		bootstrap = list(R = 1000L, type = "ordinary",
90		show.progress = FALSE),
91		output = "lavaan",
92		bootstrap.args = bootstrap) {
93		# "bootstrap" is the new way to specify arguments, replacing bootstrap.args
94	!	if (!missing(bootstrap.args)) {
95	!	lav_msg_warn(gettext(
96	!	"'bootstrap.args' is deprecated; please use 'bootstrap' instead."))
97	!	bootstrap <- bootstrap.args
98		}
99
100		# check model= argument
101	!	has.sam.object.flag <- FALSE
102	!	if (inherits(model, "lavaan") && !is.null(model@internal$sam.method)) {
103	!	has.sam.object.flag <- TRUE
104		}
105
106		# check sam.method
107	!	sam.method <- tolower(sam.method)
108	!	if (!sam.method %in% c("local", "global", "fsr", "cfsr")) {
109	!	lav_msg_stop(gettextf("unknown option for sam.method: [%s]",
110	!	"available options are local, global, fsr and cfs."))
111		}
112
113		# ------------- handling of warn/debug/verbose switches ----------
114	!	dotdotdot <- list(...)
115	!	if( length(dotdotdot) > 0L) {
116	!	if (!is.null(dotdotdot$debug)) {
117	!	current.debug <- lav_debug()
118	!	if (lav_debug(dotdotdot$debug))
119	!	on.exit(lav_debug(current.debug), TRUE)
120	!	dotdotdot$debug <- NULL
121	!	if (lav_debug()) {
122	!	dotdotdot$warn <- TRUE # force warnings if debug
123	!	dotdotdot$verbose <- TRUE # force verbose if debug
124		}
125		}
126	!	if (!is.null(dotdotdot$warn)) {
127	!	current.warn <- lav_warn()
128	!	if (lav_warn(dotdotdot$warn))
129	!	on.exit(lav_warn(current.warn), TRUE)
130	!	dotdotdot$warn <- NULL
131		}
132	!	if (!is.null(dotdotdot$verbose)) {
133	!	current.verbose <- lav_verbose()
134	!	if (lav_verbose(dotdotdot$verbose))
135	!	on.exit(lav_verbose(current.verbose), TRUE)
136	!	dotdotdot$verbose <- NULL
137		}
138		# check for conditional.x= argument
139		# if (!sam.method == "global" && !is.null(dotdotdot$conditional.x) &&
140		# dotdotdot$conditional.x) {
141		# lav_msg_warn(gettext(
142		# "local sam() does not support conditional.x = TRUE (yet) -> switching to
143		# conditional.x = FALSE"))
144		# dotdotdot$conditional.x <- FALSE
145		# }
146		# check for orthogonal= argument
147	!	if (!is.null(dotdotdot$orthogonal) &&
148	!	dotdotdot$orthogonal &&
149	!	sam.method != "global") {
150	!	lav_msg_warn(gettext(
151	!	"local sam does not support orthogonal = TRUE -> switching to
152	!	global sam"))
153	!	sam.method <- "global"
154		}
155		} # length(dotdotdot) > 0L
156
157		# check output= argument
158	!	output <- tolower(output)
159	!	if (output %in% c("list", "list.step1.only", "lavaan")) {
160		# nothing to do
161		} else {
162	!	lav_msg_stop(gettext("output should be \"list\" or \"lavaan.\""))
163		}
164
165		#
166
167		# check se= argument
168	!	if (!missing(se)) {
169	!	se <- tolower(se)
170		# aliases
171	!	if (se %in% c("two-step", "two_step", "two.step")) {
172	!	se <- "twostep"
173	!	} else if(se %in% c("two-step-robust", "two-step.robust",
174	!	"two_step_robust", "two.step.robust",
175	!	"twostep.robust")) {
176	!	se <- "twostep.robust"
177		}
178	!	else if (se %in% c("ij", "local")) {
179	!	se <- "local"
180		}
181		# check if valid
182	!	if (!se %in% c("standard", "naive", "twostep", "local", "local.nt",
183	!	"twostep.robust", "bootstrap", "none")) {
184	!	lav_msg_stop(gettext(
185	!	"se= argument must be twostep, twostep.robust, bootstrap, or local"))
186		}
187		# check for local
188	!	if (se %in% c("local", "local.nt")) {
189	!	if (!sam.method %in% c("local", "fsr", "cfsr")) { # for now
190	!	lav_msg_stop(gettext("local se only available if sam.method is local, fsr, or cfsr"))
191		}
192		}
193		}
194		# default is twostep
195
196		# check for gamma.unbiased
197	!	if (is.null(dotdotdot$gamma.unbiased)) {
198		# put in TRUE in dotdotdot # lavaan default is still FALSE
199	!	dotdotdot$gamma.unbiased <- TRUE
200		}
201
202
203		###############################################
204		# STEP 0: process full model, without fitting #
205		###############################################
206	!	if (has.sam.object.flag) {
207	!	FIT <- model
208		# restore options
209	!	FIT@Options <- FIT@internal$sam.lavoptions
210		# extract other argments from FIT@internal, unless specified as arguments
211	!	if (missing(mm.list)){
212	!	mm.list <- FIT@internal$sam.mm.list
213		}
214	!	if (missing(mm.args)){
215	!	mm.args <- FIT@internal$sam.mm.args
216		}
217	!	if (missing(struc.args)) {
218	!	struc.args <- FIT@internal$sam.struc.args
219		}
220	!	if (missing(sam.method)) {
221	!	sam.method <- FIT@internal$sam.method
222		}
223	!	if (missing(local.options)) {
224	!	local.options <- FIT@internal$sam.local.options
225		}
226	!	if (missing(global.options)) {
227	!	global.options <- FIT@internal$sam.global.options
228		}
229	!	if (missing(se)) {
230	!	se <- FIT@Options$se
231		} else {
232	!	FIT@Options$se <- se
233		}
234	!	if (missing(cmd)) {
235	!	cmd <- FIT@internal$sam.cmd
236		}
237		# remove @internal slot
238	!	FIT@internal <- list()
239		} else {
240	!	FIT <- lav_sam_step0(
241	!	cmd = cmd, model = model, data = data, se = se,
242	!	sam.method = sam.method, dotdotdot = dotdotdot
243		)
244
245		# check for data.type == "none"
246	!	if (FIT@Data@data.type == "none") {
247		# we are done; perhaps we only wished to create a FIT object?
248	!	return(FIT)
249		#lav_msg_stop(gettext("no data or sample statistics are provided."))
250		}
251
252		# check if we have categorical data
253	!	if (FIT@Model@categorical) {
254		# switch to M.method = "ULS"
255	!	local.options[["M.method"]] <- "ULS"
256		# if sam.method = "global", force estimator to DWLS in struc par
257	!	if (sam.method == "global" &&
258	!	!is.null(struc.args[["estimator"]]) &&
259	!	struc.args[["estimator"]] == "ML") {
260	!	struc.args[["estimator"]] <- "DWLS"
261		}
262		}
263
264		# check if we have latent interactions
265	!	lv.interaction.flag <- FALSE
266	!	if (length(unlist(FIT@pta$vnames$lv.interaction)) > 0L) {
267	!	lv.interaction.flag <- TRUE
268	!	if (!se %in% c("none", "bootstrap")) {
269	!	se <- "local"
270	!	FIT@Options$se <- se
271		}
272		}
273
274		# check for multiple groups/blocks
275	!	if (FIT@Model@nblocks > 1L && se == "local") {
276	!	lav_msg_stop(gettext("se = \"local\" not available (yet) if multiple
277	!	blocks (groups, levels) are involved."))
278		}
279		}
280
281	!	lavoptions <- lavInspect(FIT, "options")
282	!	if (lav_verbose()) {
283	!	cat("This is sam using sam.method = ", sam.method, ".\n", sep = "")
284		}
285
286		##############################################
287		# STEP 1: fit each measurement model (block) #
288		##############################################
289	!	if (lav_verbose()) {
290	!	cat("Fitting the measurement part:\n")
291		}
292	!	STEP1 <- lav_sam_step1(
293	!	cmd = cmd, mm.list = mm.list, mm.args = mm.args,
294	!	FIT = FIT, sam.method = sam.method
295		)
296
297		##################################################
298		# STEP 1b: compute Var(eta) and E(eta) per block #
299		# only needed for local approach! #
300		##################################################
301	!	if (sam.method %in% c("local", "fsr", "cfsr")) {
302		# default local.options
303	!	local.opt <- list(
304	!	M.method = "ML",
305	!	lambda.correction = TRUE,
306	!	alpha.correction = 0L,
307	!	twolevel.method = "h1"
308		)
309	!	local.options <- modifyList(local.opt, local.options,
310	!	keep.null = FALSE
311		)
312
313		# collect COV/YBAR sample statistics per block from FIT
314	!	out <- lav_sam_get_cov_ybar(FIT = FIT, local.options = local.options)
315	!	STEP1$COV <- out$COV
316	!	STEP1$YBAR <- out$YBAR
317
318		# compute EETA/VETA
319	!	STEP1 <- lav_sam_step1_local(
320	!	STEP1 = STEP1, FIT = FIT,
321	!	sam.method = sam.method,
322	!	local.options = local.options,
323	!	return.cov.iveta2 = (se %in% c("local", "local.nt"))
324		)
325		}
326
327		##################################################
328		# STEP 1c: jacobian of vech(VETA) = f(vech(S)) #
329		# only needed for local approach! #
330		# only if se = "local" #
331		##################################################
332	!	if (se %in% c("local", "local.nt")) {
333	!	Gamma.eta <- vector("list", length = FIT@Data@ngroups)
334	!	if (lv.interaction.flag) {
335	!	for (g in seq_len(FIT@Data@ngroups)) { # group or block
336		# initial Gamma.eta
337	!	Gamma.eta.init <- STEP1$COV.IVETA2[[g]]
338		# compute 'additional variability' due to step1
339	!	Gamma.eta.add <- lav_sam_gamma_add(STEP1 = STEP1, FIT = FIT, group = g)
340	!	Gamma.eta[[g]] <- Gamma.eta.init + Gamma.eta.add
341		}
342		} else {
343	!	JAC <- lav_sam_step1_local_jac(STEP1 = STEP1, FIT = FIT)
344	!	if (se == "local") {
345	!	Gamma <- FIT@SampleStats@NACOV
346	!	} else if (se == "local.nt") {
347	!	Gamma <- lav_object_gamma(lavobject = FIT, ADF = FALSE)
348		}
349
350	!	for (g in seq_len(FIT@Data@ngroups)) {
351	!	Gamma.eta[[g]] <- JAC[[g]] %% Gamma[[g]] %% t(JAC[[g]])
352		}
353	!	STEP1$JAC <- JAC
354		} # no lv-interaction
355	!	STEP1$Gamma.eta <- Gamma.eta
356		}
357
358	!	if (output == "list.step1.only") {
359		# stop here, return interim results
360	!	return(STEP1)
361		}
362
363		####################################
364		# STEP 2: estimate structural part #
365		####################################
366
367	!	STEP2 <- lav_sam_step2(
368	!	STEP1 = STEP1, FIT = FIT,
369	!	sam.method = sam.method, struc.args = struc.args
370		)
371
372		# make sure step1.free.idx and step2.free.idx are disjoint
373	!	both.idx <- which(STEP1$step1.free.idx %in% STEP2$step2.free.idx)
374	!	if (length(both.idx) > 0L) {
375	!	STEP1$step1.free.idx <- STEP1$step1.free.idx[-both.idx]
376		# STEP1$Sigma.11[both.idx,] <- 0
377		# STEP1$Sigma.11[,both.idx] <- 0
378	!	if (!is.null(STEP1$Sigma.11)) { # maybe se = "none"...
379	!	STEP1$Sigma.11 <- STEP1$Sigma.11[-both.idx, -both.idx]
380		}
381		}
382
383	!	if (output == "list" && lavoptions$se == "none") {
384	!	return(c(STEP1, STEP2))
385		}
386
387		################################################################
388		# Step 3: assemble results in a 'dummy' JOINT model for output #
389		################################################################
390	!	if (lav_verbose()) {
391	!	cat("Creating JOINT lavaan object ... ")
392		}
393	!	JOINT <- lav_sam_step3_joint(
394	!	FIT = FIT, PT = STEP2$PT,
395	!	sam.method = sam.method
396		)
397		# fill information from FIT.PA
398	!	JOINT@Options$optim.method <- STEP2$FIT.PA@Options$optim.method
399	!	JOINT@Model@estimator <- FIT@Options$estimator # could be DWLS!
400	!	if (sam.method %in% c("local", "fsr", "cfsr")) {
401	!	JOINT@optim <- STEP2$FIT.PA@optim
402	!	JOINT@test <- STEP2$FIT.PA@test
403		}
404		# fill in vcov/se information from step 1
405	!	if (!lavoptions$se %in% c("none", "bootstrap")) {
406	!	JOINT@Options$se <- lavoptions$se # naive/twostep/none/local/bootstrap
407	!	if (JOINT@Model@ceq.simple.only) {
408	!	VCOV.ALL <- matrix(
409	!	0, JOINT@Model@nx.unco,
410	!	JOINT@Model@nx.unco
411		)
412		} else {
413	!	VCOV.ALL <- matrix(
414	!	0, JOINT@Model@nx.free,
415	!	JOINT@Model@nx.free
416		)
417		}
418	!	VCOV.ALL[STEP1$step1.free.idx, STEP1$step1.free.idx] <- STEP1$Sigma.11
419	!	JOINT@vcov <- list(
420	!	se = lavoptions$se,
421	!	information = lavoptions$information[1],
422	!	vcov = VCOV.ALL
423		)
424		# no need to fill @ParTable$se, as step1 SE values should already
425		# be in place
426		}
427
428	!	if (lav_verbose()) {
429	!	cat("done.\n")
430		}
431
432		##############################################
433		# Step 4: compute standard errors for step 2 #
434		##############################################
435
436	!	if (lavoptions$se == "bootstrap") {
437	!	if (lav_verbose()) {
438	!	cat("computing VCOV for se = bootstrap ...")
439		}
440		# construct temporary sam object, so that lav_bootstrap_internal() can
441		# use it
442	!	SAM <- lav_sam_table(
443	!	JOINT = JOINT, STEP1 = STEP1,
444	!	FIT.PA = STEP2$FIT.PA,
445	!	cmd = cmd, lavoptions = FIT@Options,
446	!	mm.args = mm.args,
447	!	struc.args = struc.args,
448	!	sam.method = sam.method,
449	!	local.options = local.options,
450	!	global.options = global.options
451		)
452	!	sam_object <- JOINT
453	!	sam_object@internal <- SAM
454	!	default.args <- list(R = 1000L, type = "ordinary",
455	!	show.progress = FALSE,
456	!	check.post = TRUE, keep.idx = FALSE)
457	!	this.args <- modifyList(default.args, bootstrap)
458	!	COEF <- lav_bootstrap_internal(object = sam_object,
459	!	R = this.args$R, show.progress = this.args$show.progress,
460	!	type = this.args$type, FUN = "coef",
461	!	check.post = this.args$check.post, keep.idx = this.args$keep.idx)
462	!	COEF.orig <- COEF
463	!	error.idx <- attr(COEF, "error.idx")
464	!	nfailed <- length(error.idx) # zero if NULL
465	!	if (nfailed > 0L) {
466	!	lav_msg_warn(gettextf(
467	!	"%s bootstrap runs failed or did not converge.", nfailed))
468		}
469	!	notok <- length(attr(COEF, "nonadmissible")) # zero if NULL
470	!	if (notok > 0L) {
471	!	lav_msg_warn(gettextf(
472	!	"%s bootstrap runs resulted in nonadmissible solutions.", notok))
473		}
474	!	if (length(error.idx) > 0L) {
475		# new in 0.6-13: we must still remove them!
476	!	COEF <- COEF[-error.idx, , drop = FALSE]
477		# this also drops the attributes
478		}
479	!	nboot <- nrow(COEF)
480	!	VarCov <- cov(COEF) * (nboot - 1) / nboot
481	!	JOINT@boot$coef <- COEF.orig
482	!	JOINT@Options$bootstrap <- this.args$R
483	!	VCOV <- list(se = "bootstrap", VCOV = VarCov)
484
485	!	if (lav_verbose()) {
486	!	cat("done.\n")
487		}
488
489		# analytic twostep/standard/naive/local
490		} else {
491	!	VCOV <- lav_sam_step2_se(
492	!	FIT = FIT, JOINT = JOINT, STEP1 = STEP1,
493	!	STEP2 = STEP2, local.options = local.options
494		)
495		}
496
497		# fill in twostep standard errors
498	!	if (lavoptions$se != "none") {
499	!	PT <- JOINT@ParTable
500	!	JOINT@Options$se <- VCOV$se
501	!	JOINT@vcov$se <- VCOV$se
502	!	if (lavoptions$se == "bootstrap") {
503	!	JOINT@vcov$vcov <- VCOV$VCOV
504		} else {
505	!	JOINT@vcov$vcov[STEP2$step2.free.idx, STEP2$step2.free.idx] <- VCOV$VCOV
506		}
507	!	PT$se <- lav_model_vcov_se(
508	!	lavmodel = JOINT@Model,
509	!	lavpartable = PT,
510	!	VCOV = JOINT@vcov$vcov
511		)
512	!	JOINT@ParTable <- PT
513		}
514
515
516
517		##################
518		# Step 5: Output #
519		##################
520
521		# assemble pieces to assemble final lavaan object
522	!	if (output == "lavaan") {
523	!	if (lav_verbose()) {
524	!	cat("Assembling results for output ... ")
525		}
526	!	SAM <- lav_sam_table(
527	!	JOINT = JOINT, STEP1 = STEP1,
528	!	FIT.PA = STEP2$FIT.PA,
529	!	cmd = cmd, lavoptions = FIT@Options,
530	!	mm.args = mm.args,
531	!	struc.args = struc.args,
532	!	sam.method = sam.method,
533	!	local.options = local.options,
534	!	global.options = global.options
535		)
536	!	res <- JOINT
537	!	res@internal <- SAM
538	!	if (lav_verbose()) {
539	!	cat("done.\n")
540		}
541		} else {
542	!	res <- c(STEP1, STEP2, VCOV)
543		}
544
545	!	if (lav_verbose()) {
546	!	cat("End of sam.\n")
547		}
548
549	!	res
550		}

1		# efa related functions
2		# YR - April 2019
3		#
4		# the lav_model_efa_rotate_x() function was based on a script orginally
5		# written by Florian Scharf (Muenster University, Germany)
6
7		# rotate solution
8		lav_model_efa_rotate <- function(lavmodel = NULL, lavoptions = NULL) {
9
10		# sanity check
11	4x	if (lavmodel@nefa == 0L \|\| lavoptions$rotation == "none") {
12	!	return(lavmodel)
13		}
14
15		# save warn and verbos settings
16	4x	current.warn <- lav_warn()
17	4x	current.verbose <- lav_verbose()
18
19		# extract unrotated parameters from lavmodel
20	4x	x.orig <- lav_model_get_parameters(lavmodel, type = "free", extra = FALSE)
21
22		# rotate, extract information from 'extra' attribute
23	4x	tmp <- lav_model_efa_rotate_x(
24	4x	x = x.orig, lavmodel = lavmodel,
25	4x	lavoptions = lavoptions, extra = TRUE
26		)
27	4x	extra <- attr(tmp, "extra")
28	4x	attr(tmp, "extra") <- NULL
29
30	4x	out <- list(GLIST = extra$GLIST, H = extra$H, lv.order = extra$lv.order)
31
32		# restore warn/verbose settings
33	4x	lav_warn(current.warn)
34	4x	lav_verbose(current.verbose)
35
36	4x	out
37		}
38
39
40		# lower-level function, needed for numDeriv
41		lav_model_efa_rotate_x <- function(x, lavmodel = NULL, lavoptions = NULL,
42		init.rot = NULL, extra = FALSE,
43		type = "free") {
44		# extract rotation options from lavoptions
45	4x	method <- lavoptions$rotation
46	4x	if (method == "none") {
47	!	return(x)
48		}
49	4x	ropts <- lavoptions$rotation.args
50
51		# place parameters into model matrices
52	4x	lavmodel.orig <- lav_model_set_parameters(lavmodel, x = x)
53
54		# GLIST
55	4x	GLIST <- lavmodel.orig@GLIST
56
57		# H per group
58	4x	H <- vector("list", lavmodel@ngroups)
59	4x	ORDER <- vector("list", lavmodel@ngroups)
60
61		# new in 0.6-22 -- three options:
62		# 1. rotate per group (default)
63		# 2. group.equal = "loadings": use first lambda matrix only
64		# 3. rotate all groups together + agreement (eg De Roover & Vermunt, 2019)
65	4x	mg.group.equal.flag <- mg.agreement.flag <- FALSE
66	4x	if (lavmodel@ngroups > 1) {
67	!	if("loadings" %in% lavoptions$group.equal) {
68	!	mg.group.equal.flag <- TRUE
69	!	} else if (ropts$mg.agreement) {
70	!	mg.agreement.flag <- TRUE
71		}
72		}
73
74		# option 1 + 2 (single group or multipgroup + no agreement)
75	4x	if (!mg.agreement.flag) {
76	4x	for (g in seq_len(lavmodel@ngroups)) {
77		# select model matrices for this group
78	4x	mm.in.group <- seq_len(lavmodel@nmat[g]) + cumsum(c(0, lavmodel@nmat))[g]
79	4x	MLIST <- GLIST[mm.in.group]
80
81		# general rotation matrix (all latent variables)
82	4x	H[[g]] <- Hg <- diag(ncol(MLIST$lambda))
83	4x	lv.order <- seq_len(ncol(MLIST$lambda))
84
85		# reconstruct full LAMBDA (in case of dummy ov's)
86	4x	LAMBDA.g <- lav_lisrel_lambda(
87	4x	MLIST = MLIST,
88	4x	ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
89	4x	ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
90	4x	ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
91	4x	ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]],
92	4x	remove.dummy.lv = TRUE
93		)
94		# reconstruct full THETA (in case of dummy ov's)
95	4x	THETA.g <- lav_lisrel_theta(
96	4x	MLIST = MLIST,
97	4x	ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
98	4x	ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
99	4x	ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
100	4x	ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]]
101		)
102
103		# fill in optimal rotation for each set
104	4x	for (set in seq_len(lavmodel@nefa)) {
105		# which ov/lv's are involved in this set?
106	4x	ov.idx <- lavmodel@ov.efa.idx[[g]][[set]]
107	4x	lv.idx <- lavmodel@lv.efa.idx[[g]][[set]]
108
109		# empty set?
110	4x	if (length(ov.idx) == 0L) {
111	!	next
112		}
113
114		# just 1 factor?
115	4x	if (length(lv.idx) < 2L) {
116		# new in 0.6-18: reflect if needed
117	1x	if (lavoptions$rotation.args$reflect) {
118	1x	tmp <- LAMBDA.g[ov.idx, lv.idx, drop = TRUE]
119	1x	if (sum(tmp) < 0) {
120	1x	MLIST$lambda[ov.idx, 1] <- -1 * MLIST$lambda[ov.idx, 1]
121		}
122		}
123	1x	next
124		}
125
126		# unrotated 'A' for this set
127	3x	A <- LAMBDA.g[ov.idx, lv.idx, drop = FALSE]
128
129		# std.ov? we use diagonal of Sigma for this set of ov's only
130	3x	if (ropts$std.ov) {
131	3x	if (mg.group.equal.flag) {
132		# compute mean THETA across groups
133	!	theta.idx <- which(names(lavmodel@GLIST) == "theta")
134	!	THETA <- Reduce("+", lavmodel@GLIST[theta.idx]) / lavmodel@ngroups
135		} else {
136	3x	THETA <- THETA.g[ov.idx, ov.idx, drop = FALSE]
137		}
138	3x	Sigma <- tcrossprod(A) + THETA
139	3x	this.ov.var <- diag(Sigma)
140		} else {
141	!	this.ov.var <- NULL
142		}
143
144		# init.rot?
145	3x	if (!is.null(init.rot) && lavoptions$rotation.args$jac.init.rot) {
146	!	init.ROT <- init.rot[[g]][lv.idx, lv.idx, drop = FALSE]
147	!	rstarts <- 0
148		} else {
149	3x	init.ROT <- NULL
150	3x	rstarts <- ropts$rstarts
151		}
152		# set warn and verbose to ropts-values
153	3x	current.warn <- lav_warn()
154	3x	current.verbose <- lav_verbose()
155	3x	if (lav_warn(ropts$warn))
156	3x	on.exit(lav_warn(current.warn), TRUE)
157	3x	if (lav_verbose(ropts$verbose))
158	!	on.exit(lav_verbose(current.verbose), TRUE)
159		# rotate this set
160	3x	res <- lav_matrix_rotate(
161	3x	A = A,
162	3x	orthogonal = ropts$orthogonal,
163	3x	method = method,
164	3x	method.args = list(
165	3x	geomin.epsilon = ropts$geomin.epsilon,
166	3x	orthomax.gamma = ropts$orthomax.gamma,
167	3x	cf.gamma = ropts$orthomax.gamma,
168	3x	oblimin.gamma = ropts$oblimin.gamma,
169	3x	promax.kappa = ropts$promax.kappa,
170	3x	target = ropts$target,
171	3x	target.mask = ropts$target.mask
172		),
173	3x	init.ROT = init.ROT,
174	3x	init.ROT.check = FALSE,
175	3x	rstarts = rstarts,
176	3x	row.weights = ropts$row.weights,
177	3x	std.ov = ropts$std.ov,
178	3x	ov.var = this.ov.var,
179	3x	algorithm = ropts$algorithm,
180	3x	reflect = ropts$reflect,
181	3x	order.lv.by = ropts$order.lv.by,
182	3x	gpa.tol = ropts$gpa.tol,
183	3x	tol = ropts$tol,
184	3x	max.iter = ropts$max.iter,
185	3x	group = g
186		)
187
188		# extract rotation matrix (note, in Asp & Muthen, 2009; this is H')
189		# note: as of 0.6-6, order.idx has already been applied to ROT,
190		# so no need to reorder rows/columns after rotation
191	3x	H.efa <- res$ROT
192
193		# fill in optimal rotation for this set
194	3x	Hg[lv.idx, lv.idx] <- H.efa
195
196		# keep track of possible re-orderings
197	3x	lv.order[lv.idx] <- lv.idx[res$order.idx]
198		} # set
199
200		# rotate all the SEM parameters
201
202		# 1. lambda
203	4x	MLIST$lambda <- t(solve(Hg, t(MLIST$lambda)))
204
205		# 2. psi (note: eq 22 Asp & Muthen, 2009: transpose reversed)
206	4x	MLIST$psi <- t(Hg) %% MLIST$psi %% Hg
207
208		# 3. beta
209	4x	if (!is.null(MLIST$beta)) {
210	!	MLIST$beta <- t(Hg) %*% t(solve(Hg, t(MLIST$beta)))
211		}
212
213		# 4. alpha
214	4x	if (!is.null(MLIST$alpha)) {
215	!	MLIST$alpha <- t(Hg) %*% MLIST$alpha
216		}
217
218		# no need for rotation: nu, theta
219
220		# store rotated matrices in GLIST
221	4x	GLIST[mm.in.group] <- MLIST
222
223		# store rotation matrix + lv.order
224	4x	H[[g]] <- Hg
225	4x	ORDER[[g]] <- lv.order
226
227		# check for group.equal
228	4x	if (mg.group.equal.flag) {
229	!	break # only rotation once
230		}
231		} # group
232
233		# if group.equal = "loadings", take care of the other groups
234	4x	if (mg.group.equal.flag) {
235	!	MLIST1 <- MLIST # first group
236	!	for (g in 2:lavmodel@ngroups) {
237	!	mm.in.group <- ( seq_len(lavmodel@nmat[g]) +
238	!	cumsum(c(0, lavmodel@nmat))[g] )
239	!	MLIST <- GLIST[mm.in.group]
240	!	MLIST$lambda <- MLIST1$lambda
241	!	MLIST$psi <- t(Hg) %% MLIST$psi %% Hg
242	!	if (!is.null(MLIST$beta)) {
243	!	MLIST$beta <- t(Hg) %*% t(solve(Hg, t(MLIST$beta)))
244		}
245	!	if (!is.null(MLIST$alpha)) {
246	!	MLIST$alpha <- t(Hg) %*% MLIST$alpha
247		}
248	!	GLIST[mm.in.group] <- MLIST
249	!	H[[g]] <- Hg
250	!	ORDER[[g]] <- lv.order
251		}
252		}
253
254		# option 3: rotation + agreement
255		} else {
256	!	lambdaList <- vector("list", length = lavmodel@ngroups)
257	!	for (g in seq_len(lavmodel@ngroups)) {
258		# select model matrices for this group
259	!	mm.in.group <- seq_len(lavmodel@nmat[g]) + cumsum(c(0, lavmodel@nmat))[g]
260	!	MLIST <- GLIST[mm.in.group]
261
262		# reconstruct full LAMBDA (in case of dummy ov's)
263	!	LAMBDA.g <- lav_lisrel_lambda(
264	!	MLIST = MLIST,
265	!	ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
266	!	ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
267	!	ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
268	!	ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]],
269	!	remove.dummy.lv = TRUE
270		)
271
272	!	lambdaList[[g]] <- LAMBDA.g
273
274		# prepare H and ORDER
275	!	H[[g]] <- diag(ncol(LAMBDA.g))
276	!	ORDER[[g]] <- seq_len(ncol(LAMBDA.g))
277		} # group
278
279		# fill in optimal rotation for each set
280	!	for (set in seq_len(lavmodel@nefa)) {
281		# which ov/lv's are involved in this set?
282	!	ov.idx <- lavmodel@ov.efa.idx[[1]][[set]] # assumed equal across groups!
283	!	lv.idx <- lavmodel@lv.efa.idx[[1]][[set]] # assumed equal across groups!
284
285		# empty set?
286	!	if (length(ov.idx) == 0L) {
287	!	next
288		}
289
290		# just 1 factor?
291		# if (length(lv.idx) < 2L) {
292		# # new in 0.6-18: reflect if needed
293		# if (lavoptions$rotation.args$reflect) {
294		# tmp <- LAMBDA.g[ov.idx, lv.idx, drop = TRUE]
295		# if (sum(tmp) < 0) {
296		# MLIST$lambda[ov.idx, 1] <- -1 * MLIST$lambda[ov.idx, 1]
297		# }
298		# }
299		# next
300		# }
301
302		# unrotated 'A' for this set
303	!	Alist <- lapply(lambdaList,
304	!	function (x) { x[ov.idx, lv.idx, drop = FALSE] })
305		# std.ov? we use diagonal of Sigma for this set of ov's only
306		# if (ropts$std.ov) {
307		# if (mg.group.equal.flag) {
308		# # compute mean THETA across groups
309		# theta.idx <- which(names(lavmodel@GLIST) == "theta")
310		# THETA <- Reduce("+", lavmodel@GLIST[theta.idx]) / lavmodel@ngroups
311		# } else {
312		# THETA <- THETA.g[ov.idx, ov.idx, drop = FALSE]
313		# }
314		# Sigma <- tcrossprod(A) + THETA
315		# this.ov.var <- diag(Sigma)
316		# } else {
317	!	this.ov.var <- NULL
318		# }
319
320		# init.rot?
321	!	if (!is.null(init.rot) && lavoptions$rotation.args$jac.init.rot) {
322	!	init.rotList <- vector("list", length = lavmodel@ngroups)
323	!	init.rotList[[g]] <- init.rot[[g]][lv.idx, lv.idx, drop = FALSE]
324	!	rstarts <- 0
325		} else {
326	!	init.rotList <- NULL
327	!	rstarts <- ropts$rstarts
328		}
329
330		# set warn and verbose to ropts-values
331	!	current.warn <- lav_warn()
332	!	current.verbose <- lav_verbose()
333	!	if (lav_warn(ropts$warn))
334	!	on.exit(lav_warn(current.warn), TRUE)
335	!	if (lav_verbose(ropts$verbose))
336	!	on.exit(lav_verbose(current.verbose), TRUE)
337	!	if (lav_verbose()) {
338	!	cat("\n")
339		}
340
341		# rotate this set
342	!	res <- lav_matrix_rotate_mg(
343	!	Alist = Alist,
344	!	orthogonal = ropts$orthogonal,
345	!	method = method,
346	!	method.args = list(
347	!	geomin.epsilon = ropts$geomin.epsilon,
348	!	orthomax.gamma = ropts$orthomax.gamma,
349	!	cf.gamma = ropts$orthomax.gamma,
350	!	oblimin.gamma = ropts$oblimin.gamma,
351	!	promax.kappa = ropts$promax.kappa,
352	!	target = ropts$target,
353	!	target.mask = ropts$target.mask
354		),
355	!	init.rotList = init.rotList,
356	!	init.ROT.check = FALSE,
357	!	rstarts = rstarts,
358		#row.weights = ropts$row.weights,
359		#std.ov = ropts$std.ov,
360		#ov.var = this.ov.var,
361	!	mg.algorithm = ropts$mg.agreement.algorithm,
362	!	mg.agreement.method = ropts$mg.agreement.method,
363	!	mg.agreement.weight = ropts$mg.agreement.weight,
364	!	reflect = ropts$reflect,
365	!	order.lv.by = ropts$order.lv.by,
366		#gpa.tol = ropts$gpa.tol,
367	!	tol = ropts$tol,
368	!	max.iter = ropts$max.iter
369		)
370	!	for (g in seq_len(lavmodel@ngroups)) {
371		# fill in optimal rotation for this set, for this group
372	!	H[[g]][lv.idx, lv.idx] <- res$rotList[[g]]
373
374		# keep track of possible re-orderings
375	!	ORDER[[g]][lv.idx] <- lv.idx[res$orderList[[g]]]
376		}
377		} # set
378
379		# rotate all the SEM parameters
380	!	for (g in seq_len(lavmodel@ngroups)) {
381	!	mm.in.group <- seq_len(lavmodel@nmat[g]) + cumsum(c(0, lavmodel@nmat))[g]
382	!	MLIST <- GLIST[mm.in.group]
383	!	Hg <- H[[g]]
384
385		# 1. lambda
386	!	MLIST$lambda <- t(solve(Hg, t(MLIST$lambda)))
387
388		# 2. psi (note: eq 22 Asp & Muthen, 2009: transpose reversed)
389	!	MLIST$psi <- t(Hg) %% MLIST$psi %% Hg
390
391		# 3. beta
392	!	if (!is.null(MLIST$beta)) {
393	!	MLIST$beta <- t(Hg) %*% t(solve(Hg, t(MLIST$beta)))
394		}
395
396		# 4. alpha
397	!	if (!is.null(MLIST$alpha)) {
398	!	MLIST$alpha <- t(Hg) %*% MLIST$alpha
399		}
400		# no need for rotation: nu, theta
401
402	!	GLIST[mm.in.group] <- MLIST
403		}
404
405		# rescale lambda again, so that sum-of-squares per columns is the same
406		# for all groups
407	!	lambdaList <- GLIST[names(GLIST) == "lambda"]
408	!	psiList <- GLIST[names(GLIST) == "psi"]
409
410	!	ss_list <- lapply(lambdaList, function(x) colSums(x^2))
411	!	ss_ave <- Reduce("+", ss_list) / length(ss_list)
412	!	scale_factor <- vector("list", length = ncol(lambdaList[[1]]))
413	!	for(g in seq_len(lavmodel@ngroups)) {
414	!	scale_factor[[g]] <- (sqrt(ss_list[[g]]) / sqrt(ss_ave))
415	!	lambdaList[[g]] <- t( t(lambdaList[[g]]) / scale_factor[[g]] )
416		}
417
418		# rescale psiList accordingly
419	!	for(g in seq_len(lavmodel@ngroups)) {
420	!	psiList[[g]] <- ( diag(scale_factor[[g]]) %% psiList[[g]] %%
421	!	diag(scale_factor[[g]]) )
422		}
423
424		# put back in GLIST
425	!	GLIST[names(GLIST) == "lambda"] <- lambdaList
426	!	GLIST[names(GLIST) == "psi"] <- psiList
427
428		} # option 3
429
430		# extract all rotated parameter estimates
431	4x	x.rot <- lav_model_get_parameters(lavmodel, GLIST = GLIST, type = type)
432
433		# extra?
434	4x	if (extra) {
435	4x	attr(x.rot, "extra") <- list(GLIST = GLIST, H = H, lv.order = ORDER)
436		}
437
438		# return rotated parameter estimates as a vector
439	4x	x.rot
440		}
441
442
443		# lower-level function, needed for numDeriv
444		lav_model_efa_rotate_border_x <- function(x, lavmodel = NULL,
445		lavoptions = NULL,
446		lavpartable = NULL) {
447		# extract rotation options from lavoptions
448	1428x	method <- lavoptions$rotation
449	1428x	ropts <- lavoptions$rotation.args
450	1428x	method.args <- list(
451	1428x	geomin.epsilon = ropts$geomin.epsilon,
452	1428x	orthomax.gamma = ropts$orthomax.gamma,
453	1428x	cf.gamma = ropts$orthomax.gamma,
454	1428x	oblimin.gamma = ropts$oblimin.gamma,
455	1428x	promax.kappa = ropts$oblimin.kappa,
456	1428x	target = ropts$target,
457	1428x	target.mask = ropts$target.mask
458		)
459
460		# place parameters into model matrices
461	1428x	lavmodel <- lav_model_set_parameters(lavmodel, x = x)
462
463		# GLIST
464	1428x	GLIST <- lavmodel@GLIST
465
466		# res
467	1428x	res <- numeric(0L)
468
469		# per group (not per block)
470	1428x	for (g in seq_len(lavmodel@ngroups)) {
471
472		# group-specific method.args
473	1428x	this.method.args <- method.args
474
475		# set group-specific target/target.mask (if needed)
476		# if target, check target matrix
477	1428x	if (method == "target.strict" \|\| method == "pst") {
478	!	target <- method.args$target
479	!	if (is.list(target)) {
480	!	this.method.args$target <- target[[g]]
481		}
482		}
483	1428x	if (method == "pst") {
484	!	target.mask <- method.args$target.mask
485	!	if (is.list(target.mask)) {
486	!	this.method.args$target.mask <- target.mask[[g]]
487		}
488		}
489
490		# select model matrices for this group
491	1428x	mm.in.group <- seq_len(lavmodel@nmat[g]) + cumsum(c(0, lavmodel@nmat))[g]
492	1428x	MLIST <- GLIST[mm.in.group]
493
494		# reconstruct full LAMBDA (in case of dummy ov's)
495	1428x	LAMBDA.g <- lav_lisrel_lambda(
496	1428x	MLIST = MLIST,
497	1428x	ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
498	1428x	ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
499	1428x	ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
500	1428x	ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]],
501	1428x	remove.dummy.lv = TRUE
502		)
503		# reconstruct full THETA (in case of dummy ov's)
504	1428x	THETA.g <- lav_lisrel_theta(
505	1428x	MLIST = MLIST,
506	1428x	ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]],
507	1428x	ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]],
508	1428x	ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]],
509	1428x	ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]]
510		)
511
512		# setnames
513	1428x	set.names <- lav_partable_efa_values(lavpartable)
514
515		# for each set
516	1428x	for (set in seq_len(lavmodel@nefa)) {
517		# check if we have any user=7 elements in this set
518		# if not, skip constraints
519	1428x	ind.idx <- which(lavpartable$op == "=~" &
520	1428x	lavpartable$group == g &
521	1428x	lavpartable$efa == set.names[set])
522	1428x	if (!any(lavpartable$user[ind.idx] == 7L)) {
523	193x	next
524		}
525
526		# which ov/lv's are involved in this set?
527	1235x	ov.idx <- lavmodel@ov.efa.idx[[g]][[set]]
528	1235x	lv.idx <- lavmodel@lv.efa.idx[[g]][[set]]
529
530		# empty set?
531	1235x	if (length(ov.idx) == 0L) {
532	!	next
533		}
534
535		# just 1 factor?
536	1235x	if (length(lv.idx) < 2L) {
537	!	next
538		}
539
540	1235x	A <- LAMBDA.g[ov.idx, lv.idx, drop = FALSE]
541	1235x	P <- nrow(A)
542	1235x	M <- ncol(A)
543
544		# for oblique, we also need PSI
545	1235x	if (!ropts$orthogonal) {
546	1235x	PSI <- MLIST$psi[lv.idx, lv.idx, drop = FALSE]
547		}
548
549		# std.ov? we use diagonal of Sigma for this set of ov's only
550	1235x	if (ropts$std.ov) {
551	1235x	THETA <- THETA.g[ov.idx, ov.idx, drop = FALSE]
552	1235x	Sigma <- tcrossprod(A) + THETA
553	1235x	this.ov.var <- diag(Sigma)
554		} else {
555	!	this.ov.var <- rep(1, P)
556		}
557
558		# choose method
559	1235x	method <- tolower(method)
560	1235x	if (method %in% c(
561	1235x	"cf-quartimax", "cf-varimax", "cf-equamax",
562	1235x	"cf-parsimax", "cf-facparsim"
563		)) {
564	!	method.fname <- "lav_matrix_rotate_cf"
565	!	this.method.args$cf.gamma <- switch(method,
566	!	"cf-quartimax" = 0,
567	!	"cf-varimax" = 1 / P,
568	!	"cf-equamax" = M / (2 * P),
569	!	"cf-parsimax" = (M - 1) / (P + M - 2),
570	!	"cf-facparsim" = 1
571		)
572	1235x	} else if (method == "target.strict") {
573	!	method.fname <- "lav_matrix_rotate_target"
574		} else {
575	1235x	method.fname <- paste("lav_matrix_rotate_", method, sep = "")
576		}
577
578		# check if rotation method exists
579	1235x	check <- try(get(method.fname), silent = TRUE)
580	1235x	if (inherits(check, "try-error")) {
581	!	lav_msg_stop(gettextf("unknown rotation method: %s", method.fname))
582		}
583
584		# 1. compute row weigths
585
586		# 1.a cov -> cor?
587	1235x	if (ropts$std.ov) {
588	1235x	A <- A * 1 / sqrt(this.ov.var)
589		}
590
591	1235x	if (ropts$row.weights == "none") {
592	1235x	weights <- rep(1.0, P)
593	!	} else if (ropts$row.weights == "kaiser") {
594	!	weights <- lav_matrix_rotate_kaiser_weights(A)
595	!	} else if (ropts$row.weights == "cureton-mulaik") {
596	!	weights <- lav_matrix_rotate_cm_weights(A)
597		} else {
598	!	lav_msg_stop(gettextf("row.weights can be",
599	!	lav_msg_view(c("none", "kaiser", "cureton-mulaik"), "or")))
600		}
601	1235x	A <- A * weights
602
603		# evaluate rotation criterion, extract GRAD
604	1235x	Q <- do.call(
605	1235x	method.fname,
606	1235x	c(list(LAMBDA = A), this.method.args, list(grad = TRUE))
607		)
608	1235x	Gq <- attr(Q, "grad")
609	1235x	attr(Q, "grad") <- NULL
610
611		# compute 'Z'
612	1235x	Z <- crossprod(A, Gq)
613
614		# compute constraints
615	1235x	if (ropts$orthogonal) {
616		# the constraint: Z == diagonal
617		# or in other words, the non-diagonal elements of
618		# Z - t(Z) are all zero
619	!	tmp <- Z - t(Z)
620	!	this.res <- lav_matrix_vech(tmp, diagonal = FALSE)
621		} else {
622	1235x	PSI.z <- PSI * diag(Z) # rescale rows only
623	1235x	tmp <- Z - PSI.z
624	1235x	out1 <- lav_matrix_vech(tmp, diagonal = FALSE)
625	1235x	out2 <- lav_matrix_vechu(tmp, diagonal = FALSE)
626	1235x	this.res <- c(out1, out2)
627		}
628
629	1235x	res <- c(res, this.res)
630		} # set
631		} # group
632
633		# return constraint vector
634	1428x	res
635		}

1		# miscellaneous functions related to graphs
2		# often using an adjancency matrix as input
3		#
4		# collecting functions that were in lav_utils.R
5		# YR 15 Oct 2025
6
7		# find index of 'ancestors' (predictors) for all nodes in a DAG
8		# given an adjacency matrix B (rows are y's, columns are x's)
9		#
10		# this (speedy!) version is written by Luc De Wilde
11		lav_graph_get_ancestors <- function(B = NULL) {
12	!	B <- abs(B)
13	!	nr <- nrow(B)
14	!	out_env <- new.env(parent = emptyenv())
15
16		# container to hold ancestor indices per node
17	!	out.idx <- vector("list", length = nr)
18
19	!	get_ancestors <- function(nr, callers) {
20	!	if (any(callers == nr)) {
21	!	lav_msg_warn(gettextf("Cycle detected for element nr %d !", nr))
22	!	return(integer(0))
23		}
24	!	x <- get0(as.character(nr), envir = out_env, ifnotfound = NULL)
25	!	if (!is.null(x)) return(x)
26	!	retval <- integer(0L)
27	!	x.direct.idx <- which(B[nr, ] != 0)
28	!	for (j in seq_along(x.direct.idx)) {
29	!	thisone <- x.direct.idx[j]
30	!	retval <- c(retval, thisone)
31	!	sub <- get_ancestors(thisone, c(callers, nr))
32	!	if (all(sub != nr)) retval <- c(retval, sub)
33		}
34	!	retval <- sort.int(unique(retval))
35	!	assign(as.character(nr), retval, envir = out_env)
36	!	retval
37		}
38
39		# run over each node
40	!	for (i in seq_len(nr)) {
41	!	out.idx[[i]] <- get_ancestors(i, integer(0))
42		} # all nodes
43	!	out.idx
44		}
45
46
47		# cluster rows/cols that are linked/connected
48		# return list of connected nodes
49		# we assume A is the square/symmetric (binary) adjacency matrix of an
50		# undirected graph
51		#
52		# this version written by Luc De Wilde
53		lav_graph_get_connected_nodes <- function(A) {
54
55		# make sure we have square symmetric matrix
56	!	A <- as.matrix(A)
57
58		# A must be square
59	!	stopifnot(nrow(A) == ncol(A))
60
61		# A must be symmetric
62	!	stopifnot(isSymmetric(A))
63
64		# set diagonal to zero (just in case)
65	!	diag(A) <- 0L
66
67		# make it logical
68	!	A <- (A != 0)
69
70		# number of cols/rows
71	!	M <- ncol(A)
72
73		# catch diagonal A
74	!	if (all(lavaan::lav_matrix_vech(A, diagonal = FALSE) == 0L)) {
75	!	return(seq_len(M))
76		}
77
78	!	visited <- rep(FALSE, M) # track visited nodes
79	!	membership <- integer(M) # component id for each node
80	!	component.id <- 0L # current component id
81
82	!	put_node_in_component <- function(node, componentid) {
83	!	visited[node] <<- TRUE
84	!	membership[node] <<- componentid
85	!	toadd <- which(A[, node])
86	!	for (n in toadd) {
87	!	if (!visited[n]) put_node_in_component(n, componentid)
88		}
89		}
90
91	!	for (node in seq_len(M)) {
92	!	if (!visited[node]) {
93	!	component.id <- component.id + 1L
94	!	put_node_in_component(node, component.id)
95		}
96		}
97
98	!	membership
99		}
100
101		# This routine tries to order the expressions such that all expressions that
102		# use a certain variable come after the expression that defines this variable.
103		# input adj.mat is an adjacency matrix
104		# when there is a 1 in element (r, c) this means that the variable
105		# defined in expression r is used in expression c.
106
107		# contributed by ldw (adapted from function defined by Kss2k, github issue #445)
108		lav_graph_order_adj_mat <- function(adj.mat, warn = TRUE) {
109	2x	adjmat <- adj.mat
110	2x	n <- nrow(adjmat)
111	2x	k <- 0
112	2x	testen <- 1:n
113	2x	while (TRUE) {
114	2x	found <- FALSE
115	2x	tests <- testen # which expressions are tested in the next loop
116	2x	for (i in tests) {
117	2x	if (all(adjmat[1:n, i] == 0)) { # var defined in expression i doesn't use
118		# vars not already defined, select as next
119	2x	k <- k + 1 # increment order counter
120	2x	adjmat[i, ] <- 0 # remove usage indicator of defined variable
121	2x	adjmat[i, i] <- k # keep order of expressions in diagonal element
122	2x	found <- TRUE
123	2x	testen <- testen[testen != i] # don't test this i in next loop
124		}
125		}
126	2x	if (k == n) return(order(diag(adjmat))) # all done
127	!	if (!found) { # no definable var found
128	!	if (warn) {
129	!	lav_msg_warn(gettext("unable to sort `:=` parameters;",
130	!	"system of defined parameters contains a cycle"))
131		}
132	!	return(seq_len(n)) # cycle detected; return original order
133		}
134		}
135		}
136
137		# This function performs the same task as lav_graph_order_adj_mat but
138		# takes as input two vectors (character or integer) of the same length
139		# defining the dependencies:
140		# inputs are vectors defined and definedby of the same length, where
141		# for each index j for these vectors
142		# node definedby[j] is used in the definition of node defined[j].
143		# This routine tries to order all nodes such that all node definitions that
144		# use a certain node come after the definition of that node.
145
146		# contributed by ldw as alternative for lav_graph_order_adj_mat
147		# this function is faster, requires less memory and handles also
148		# character vectors
149		lav_graph_topological_sort <- function(defined, definedby, warn = TRUE) {
150	!	nodes <- unique(c(definedby, defined))
151	!	n <- length(nodes)
152	!	rv <- vector(mode(definedby), n)
153	!	k <- 0L
154	!	testnodes <- rep(TRUE, n)
155	!	testedges <- rep(TRUE, length(defined))
156	!	while (TRUE) {
157	!	found <- FALSE
158	!	tests <- which(testnodes)
159	!	for (i in tests) {
160	!	tocheck <- nodes[i]
161	!	if (all(tocheck != defined[testedges])) {
162	!	k <- k + 1L
163	!	testnodes[i] <- FALSE
164	!	rv[k] <- tocheck
165	!	found <- TRUE
166	!	testedges[definedby == tocheck] <- FALSE
167		}
168		}
169	!	if (k == n) return(rv) # all done
170	!	if (!found) { # no definable node found
171	!	if (warn) {
172	!	lav_msg_warn(gettext("unable to sort;",
173	!	"dependencies contain a cycle"))
174		}
175	!	return(nodes) # cycle detected; return original order
176		}
177		}
178		}
179
180		# Topological grouping and placing of nodes in a matrix.
181		# Nodes which need to be placed at a border are given in argument bordernodes.
182		# This routine does a topological sort and returns a data.frame with the nodes,
183		# their position in a matrix (rows, cols) and an indication of root
184		# (no dependencies, indic == "r") or
185		# leave (no other nodes depend on this one, indic == "l"), as follows :
186		# the first column contains all nodes without dependencies (1) (2)
187		# the second column contains nodes with only dependency
188		# in the first column (1)(3)
189		# the third column contains nodes with only dependencies in the first and
190		# second, with at least one in the second column and so on (*3)
191		# (*1) nodes with successors but no successors in the next column are promoted
192		# to the column just before the least column of the successors, except
193		# the nodes mentioned in bordernodes and in the first column.
194		# (*2) the rows in the first column are chosen so that they are in the
195		# neighborhood of the mean of the rows from the nodes depending on them.(*4)
196		# (*3) the rows in the second to last column are chosen so that the sum of the
197		# row-distances to connected nodes is minimized
198		# (*4) if there are nodes forced to the top border in columns 2 through
199		# maxcol-1, the items in column1s 1 and maxcol cannot occupy the first row;
200		# analogue for the bottom
201		lav_graph_topological_matrix <- function(
202		defined,
203		definedby,
204		bordernodes = character(0),
205		warn = TRUE) {
206	!	rv <- lav_graph_topological_sort(defined, definedby, warn)
207	!	n <- length(rv)
208	!	rvrow <- integer(n)
209	!	rvcol <- integer(n)
210	!	rvindic <- character(n)
211		# position nodes in matrix, column by column, and mark root and leave nodes
212		# rows are assigned but not yet adapted
213	!	colmax <- 0L
214	!	bordersincol <- 0L
215	!	topborderfixed <- FALSE
216	!	bottomborderfixed <- FALSE
217	!	for (i in seq.int(n)) {
218	!	predecessors <- definedby[rv[i] == defined]
219	!	followers <- defined[rv[i] == definedby]
220	!	if (length(predecessors) == 0L) {
221	!	rvcol[i] <- 1L
222	!	colmax[1L] <- colmax[1L] + 1L
223	!	rvrow[i] <- colmax[1L]
224	!	rvindic[i] <- "r" # root
225		} else {
226	!	if (length(followers) == 0L) {
227	!	rvindic[i] <- "l"
228		}
229	!	predecessor.ind <- match(predecessors, rv)
230	!	rvcol[i] <- max(rvcol[predecessor.ind]) + 1L
231	!	if (length(colmax) < rvcol[i]) {
232	!	colmax[rvcol[i]] <- 1L
233	!	bordersincol <- 0L
234		} else {
235	!	colmax[rvcol[i]] <- colmax[rvcol[i]] + 1L
236		}
237	!	rvrow[i] <- colmax[rvcol[i]]
238	!	if (rv[i] %in% bordernodes && rvindic[i] != "l") {
239	!	bordersincol <- bordersincol + 1L
240	!	topborderfixed <- TRUE
241	!	if (bordersincol == 2L) bottomborderfixed <- TRUE
242	!	if (bordersincol > 2L) {
243	!	rvcol[i] <- rvcol[i] + 1L
244	!	colmax[rvcol[i]] <- 1L
245	!	rvrow[i] <- colmax[rvcol[i]]
246		}
247		}
248		}
249		}
250		# increment columns ? (*)
251	!	incremented <- TRUE
252	!	while (incremented) {
253	!	incremented <- FALSE
254	!	for (i in seq_along(rv)) {
255	!	if (rvindic[i] != "l" && !(rv[i] %in% bordernodes && rvindic[i] == "r")) {
256	!	followers <- defined[rv[i] == definedby]
257	!	followers.ind <- match(followers, rv)
258	!	mincol <- min(rvcol[followers.ind])
259	!	if (rvcol[i] < mincol - 1L) {
260	!	incremented <- TRUE
261	!	curcol <- rvcol[i]
262	!	rvcol[i] <- mincol - 1L
263		# adapt rows in curcol
264	!	rvrow[rvcol == curcol & rvrow > rvrow[i]] <-
265	!	rvrow[rvcol == curcol & rvrow > rvrow[i]] - 1L
266	!	colmax[curcol] <- colmax[curcol] - 1L
267		# adapt rows in newcol
268	!	colmax[mincol - 1L] <- colmax[mincol - 1L] + 1L
269	!	rvrow[i] <- colmax[mincol - 1L]
270		}
271		}
272		}
273		}
274		# place bordernodes in columns 2 through maxcol-1 in the first or last row
275	!	for (col in seq.int(2L, length(colmax) - 1L)) {
276	!	bordernodes.incol <- which(rvcol == col & rv %in% bordernodes)
277	!	if (length(bordernodes.incol) > 0L) {
278	!	totop <- bordernodes.incol[1L]
279	!	if (rvrow[totop] != 1L) {
280	!	swappie <- which(rvcol == col & rvrow == 1L)
281	!	rvrow[swappie] <- rvrow[totop]
282	!	rvrow[totop] <- 1L
283		}
284		}
285	!	if (length(bordernodes.incol) > 1L) {
286	!	tobottom <- bordernodes.incol[2L]
287	!	if (rvrow[tobottom] != colmax[col]) {
288	!	swappie <- which(rvcol == col & rvrow == colmax[col])
289	!	rvrow[swappie] <- rvrow[tobottom]
290	!	rvrow[tobottom] <- max(colmax)
291		}
292		}
293		}
294		# help function to order doubles as integers in a specified range
295	!	order_doubles_interval <- function(inorder, outrange) {
296	!	stopifnot(length(inorder) < outrange[2] - outrange[1] + 2)
297	!	if (length(inorder) == 1) {
298	!	if (inorder >= outrange[1L] && inorder <= outrange[2L]) {
299	!	return(as.integer(inorder))
300		}
301	!	return(as.integer(sum(outrange) / 2))
302		}
303	!	in.order <- order(inorder)
304	!	in.order[in.order] <- seq_along(inorder)
305	!	if (length(inorder) == outrange[2] - outrange[1] + 1) {
306	!	return(as.integer(outrange[1]) + in.order - 1L)
307		}
308	!	as.integer(outrange[1] + (in.order - 1L) *
309	!	(outrange[2] - outrange[1] + 0.99) / (length(in.order) - 1L))
310		}
311		# arrange nodes in first column (***)
312	!	rowmax <- max(colmax)
313	!	addrows <- 0L
314	!	if (topborderfixed) addrows <- 1L
315	!	if (bottomborderfixed) addrows <- 2L
316	!	rowmax <- max(colmax, colmax[1L] + addrows, colmax[length(colmax)] + addrows)
317	!	nodescol1 <- which(rvcol == 1L)
318	!	optimalrows <- sapply(nodescol1, function(ci) {
319	!	nextnodes.ind <- which(rv[ci] == definedby)
320	!	if (length(nextnodes.ind) == 0L) {
321	!	colmax[1L] / 2
322		} else {
323	!	nextnodes <- defined[nextnodes.ind]
324	!	mean(rvrow[match(nextnodes, rv)])
325		}
326		})
327	!	interval1l <- c(
328	!	if (topborderfixed) 2L else 1L,
329	!	if (bottomborderfixed) rowmax - 1L else rowmax
330		)
331	!	rvrow[nodescol1] <- order_doubles_interval(optimalrows, interval1l)
332
333		# adapt rows in columns to match as close as possible the rows of the
334		# connected nodes in prior column(s), except for
335		# borders for all but the last column: (**)
336	!	if (length(colmax) > 1L) {
337	!	for (c in seq.int(2L, length(colmax))) {
338	!	if (c == length(colmax)) {
339	!	cnodes.ind <- which(rvcol == c)
340	!	interval <- interval1l
341		} else {
342	!	cnodes.ind <- which(rvcol == c & !(rv %in% bordernodes))
343	!	if (length(cnodes.ind) == 0L) next
344	!	interval <- range(rvrow[cnodes.ind])
345	!	interval[2L] <- max(interval[2L], colmax - 1L)
346		}
347	!	optimalrows <- sapply(cnodes.ind, function(ci) {
348	!	prevnodes.ind <- which(rv[ci] == defined)
349	!	if (length(prevnodes.ind) == 0L) {
350	!	rvrow[ci]
351		} else {
352	!	prevnodes <- definedby[prevnodes.ind]
353	!	mean(rvrow[match(prevnodes, rv)])
354		}
355		})
356	!	rvrow[cnodes.ind] <- order_doubles_interval(optimalrows, interval)
357		}
358		}
359		# order on column, then row, and return
360	!	neworder <- order(rvcol * 1000L + rvrow)
361	!	stopifnot(length(neworder) == length(unique(neworder)))
362	!	data.frame(
363	!	nodes = rv[neworder],
364	!	rows = rvrow[neworder],
365	!	cols = rvcol[neworder],
366	!	indic = rvindic[neworder]
367		)
368		}

1		# utility functions
2		#
3		# initial version: YR 25/03/2009
4
5		# multivariate normal random number generation
6		# replacement for MASS::mvrnorm for better cross-machine reproducibility
7		# see: https://blog.djnavarro.net/posts/2025-05-18_multivariate-normal-sampling-floating-point/
8		#
9		# the issue with MASS::mvrnorm is that it uses eigendecomposition with a
10		# transformation matrix (sqrt(Lambda) Q') that is NOT invariant to eigenvector
11		# sign flips. this leads to irreproducible results across machines even with
12		# the same random seed. this implementation follows mvtnorm::rmvnorm which uses:
13		# - eigen: Q sqrt(Lambda) Q' which IS invariant to sign flips (default)
14		# - svd: similar to eigen, also invariant
15		# - chol: unique factorization
16		# eigen is the default to match MASS::mvrnorm's approach while fixing the
17		# sign-flip issue with the invariant formula
18		lav_mvrnorm <- function(n = 1, mu, Sigma, tol = 1e-06, empirical = FALSE,
19		method = "eigen", checkSymmetry = TRUE, byrow = FALSE) {
20	!	p <- length(mu)
21
22		# check symmetry (like mvtnorm)
23	!	if (checkSymmetry && !isSymmetric(Sigma,
24	!	tol = sqrt(.Machine$double.eps),
25	!	check.attributes = FALSE
26		)) {
27	!	lav_msg_stop(gettext("'Sigma' must be a symmetric matrix in lav_mvrnorm"))
28		}
29
30		# check dimensions (like mvtnorm)
31	!	if (p != nrow(Sigma)) {
32	!	lav_msg_stop(gettext("incompatible arguments in lav_mvrnorm"))
33		}
34
35		# compute transformation matrix R based on method (following mvtnorm exactly)
36	!	method <- match.arg(method, c("chol", "eigen", "svd"))
37
38	!	R <- if (method == "eigen") {
39	!	ev <- eigen(Sigma, symmetric = TRUE)
40	!	if (!all(ev$values >= -tol * abs(ev$values[1L]))) {
41	!	warning("sigma is numerically not positive semidefinite")
42		}
43		# Q sqrt(Lambda) Q' - invariant to sign flips
44	!	t(ev$vectors %% (t(ev$vectors) sqrt(pmax(ev$values, 0))))
45	!	} else if (method == "svd") {
46	!	s. <- svd(Sigma)
47	!	if (!all(s.$d >= -tol * abs(s.$d[1L]))) {
48	!	warning("sigma is numerically not positive semidefinite")
49		}
50	!	t(s.$v %% (t(s.$u) sqrt(pmax(s.$d, 0))))
51	!	} else if (method == "chol") {
52	!	R <- chol(Sigma, pivot = TRUE)
53	!	R[, order(attr(R, "pivot"))]
54		}
55
56		# for names (fallback to dimnames of Sigma if mu has no names)
57	!	nm <- names(mu)
58	!	if (is.null(nm) && !is.null(dn <- dimnames(Sigma))) {
59	!	nm <- dn[[1L]]
60		}
61
62	!	if (empirical) {
63		# generate standard normal, then apply empirical transformation
64	!	X <- matrix(stats::rnorm(p * n), n, p, byrow = byrow)
65	!	X <- scale(X, center = TRUE, scale = FALSE) # center
66	!	X <- X %*% svd(X, nu = 0)$v # orthogonalize
67	!	X <- scale(X, center = FALSE, scale = TRUE) # unit variance
68
69		# transform by R
70	!	X <- sweep(X %*% R, 2, mu, "+")
71	!	colnames(X) <- nm
72
73	!	if (n == 1) drop(X) else X
74		} else {
75		# generate samples (following mvtnorm exactly)
76	!	X <- matrix(stats::rnorm(n * p), nrow = n, byrow = byrow) %*% R
77	!	X <- sweep(X, 2, mu, "+")
78	!	colnames(X) <- nm
79
80	!	if (n == 1) drop(X) else X
81		}
82		}
83
84		# outlier detection based on inter-quartile range
85		# same as boxplot.stats, but returning the indices (not the values)
86		lav_sample_outlier_idx <- function(x, coef = 1.5) {
87	!	if (coef < 0) {
88	!	lav_msg_stop(gettext("'coef' must not be negative"))
89		}
90	!	stats <- stats::fivenum(x, na.rm = TRUE)
91	!	iqr <- diff(stats[c(2, 4)])
92	!	if (coef == 0) {
93	!	return(seq_len(length(x)))
94		} else {
95	!	out <- if (!is.na(iqr)) {
96	!	which(x < (stats[2L] - coef * iqr) \| x > (stats[4L] + coef * iqr))
97		} else {
98	!	which(!is.finite(x))
99		}
100		}
101	!	out
102		}
103
104		# sd with trimming
105		lav_sample_trimmed_sd <- function(x, na.rm = TRUE, trim = 0) {
106	!	if (isTRUE(na.rm)) {
107	!	x <- x[!is.na(x)]
108		}
109	!	n <- length(x)
110	!	if (trim > 0 && n) {
111	!	if (is.complex(x)) {
112	!	lav_msg_stop(gettext("trimmed means are not defined for complex data"))
113		}
114	!	if (anyNA(x)) {
115	!	return(NA_real_)
116		}
117	!	if (trim >= 0.5) {
118	!	return(stats::median(x, na.rm = FALSE))
119		}
120	!	lo <- floor(n * trim) + 1
121	!	hi <- n + 1 - lo
122	!	x <- sort.int(x, partial = unique(c(lo, hi)))[lo:hi]
123		}
124	!	sd(x)
125		}
126
127		# mdist = Mahalanobis distance
128		lav_sample_mdist <- function(Y, Mp = NULL, wt = NULL,
129		Mu = NULL, Sigma = NULL,
130		Sinv.method = "eigen", ginv = TRUE,
131		rescale = FALSE) {
132		# check input
133	!	Y <- as.matrix(Y)
134	!	P <- NCOL(Y)
135	!	if (!is.null(wt)) {
136	!	N <- sum(wt)
137		} else {
138	!	N <- NROW(Y)
139		}
140	!	NY <- NROW(Y)
141
142		# missing data?
143	!	missing.flag <- anyNA(Y)
144
145		# missing patterns?
146	!	if (missing.flag && is.null(Mp)) {
147	!	Mp <- lav_data_missing_patterns(Y)
148		}
149
150		# no Mu? compute sample mean
151	!	if (is.null(Mu)) {
152	!	Mu <- colMeans(Y, na.rm = TRUE)
153		}
154
155		# no Sigma?
156	!	if (is.null(Sigma)) {
157	!	if (missing.flag) {
158	!	out <- lav_mvnorm_missing_h1_estimate_moments(
159	!	Y = Y, Mp = Mp,
160	!	wt = wt
161		)
162	!	Mu <- out$Mu
163	!	Sigma <- out$Sigma
164		} else {
165	!	if (!is.null(wt)) {
166	!	out <- stats::cov.wt(Y, wt = wt, method = "ML")
167	!	Sigma <- out$cov
168	!	Mu <- out$center
169		} else {
170	!	Sigma <- stats::cov(Y, use = "pairwise")
171		# rescale?
172	!	if (rescale) {
173	!	Sigma <- ((N - 1) / N) * Sigma
174		}
175		}
176		}
177		}
178
179		# subtract Mu
180	!	Yc <- t(t(Y) - Mu)
181
182		# DIST per case
183	!	DIST <- rep(as.numeric(NA), NY)
184
185		# invert Sigma
186	!	if (ginv) {
187	!	Sigma.inv <- MASS::ginv(Sigma)
188		} else {
189	!	Sigma.inv <-
190	!	try(
191	!	lav_matrix_symmetric_inverse(
192	!	S = Sigma, logdet = FALSE,
193	!	Sinv.method = Sinv.method
194		),
195	!	silent = TRUE
196		)
197	!	if (inherits(Sigma.inv, "try-error")) {
198	!	lav_msg_warn(gettext(
199	!	"problem computing distances: could not invert Sigma"
200		))
201	!	return(DIST)
202		}
203		}
204
205		# complete data?
206	!	if (!missing.flag) {
207		# center factor scores
208	!	Y.c <- t(t(Y) - Mu)
209		# Mahalobis distance
210	!	DIST <- rowSums((Y.c %% Sigma.inv) Y.c)
211
212		# missing data?
213		} else {
214		# for each pattern, compute sigma.inv; compute DIST for all
215		# observations of this pattern
216	!	for (p in seq_len(Mp$npatterns)) {
217		# observed values for this pattern
218	!	var.idx <- Mp$pat[p, ]
219
220		# missing values for this pattern
221	!	na.idx <- which(!var.idx)
222
223		# identify cases with this pattern
224	!	case.idx <- Mp$case.idx[[p]]
225
226		# invert Sigma for this pattern
227	!	if (length(na.idx) > 0L) {
228	!	if (ginv) {
229	!	sigma.inv <- MASS::ginv(Sigma[-na.idx, -na.idx, drop = FALSE])
230		} else {
231	!	sigma.inv <-
232	!	lav_matrix_symmetric_inverse_update(
233	!	S.inv = Sigma.inv,
234	!	rm.idx = na.idx, logdet = FALSE
235		)
236		}
237		} else {
238	!	sigma.inv <- Sigma.inv
239		}
240
241	!	if (Mp$freq[p] == 1L) {
242	!	DIST[case.idx] <- sum(sigma.inv *
243	!	crossprod(Yc[case.idx, var.idx, drop = FALSE]))
244		} else {
245	!	DIST[case.idx] <-
246	!	rowSums(Yc[case.idx, var.idx, drop = FALSE] %% sigma.inv
247	!	Yc[case.idx, var.idx, drop = FALSE])
248		}
249		} # patterns
250		} # missing data
251
252		# use weights? (no for now)
253		# DIST <- DIST * wt
254
255	!	DIST
256		}
257
258		# convert correlation matrix + standard deviations to covariance matrix
259		# based on cov2cor in package:stats
260		lav_cor2cov <- function(R, sds, names = NULL) {
261	4x	p <- (d <- dim(R))[1L]
262	4x	if (!is.numeric(R) \|\| length(d) != 2L \|\| p != d[2L]) {
263	!	lav_msg_stop(gettext("'V' is not a square numeric matrix"))
264		}
265
266	4x	if (any(!is.finite(sds))) {
267	!	lav_msg_warn(gettext(
268	!	"sds had 0 or NA entries; non-finite result is doubtful"
269		))
270		}
271
272		# if(sum(diag(R)) != p)
273		# stop("The diagonal of a correlation matrix should be all ones.")
274
275	4x	if (p != length(sds)) {
276	!	lav_msg_stop(gettext("The standard deviation vector and correlation matrix
277	!	have a different number of variables"))
278		}
279
280	4x	S <- R
281	4x	S[] <- sds * R * rep(sds, each = p)
282
283		# optionally, add names
284	4x	if (!is.null(names)) {
285	!	stopifnot(length(names) == p)
286	!	rownames(S) <- colnames(S) <- names
287		}
288
289	4x	S
290		}
291
292		# convert characters within single quotes to numeric vector
293		# eg. s <- '3 4.3 8e-3 2.0'
294		# x <- lav_char2num(s)
295		lav_char2num <- function(s = "") {
296		# first, strip all ',' or ';'
297	5x	s. <- gsub(",", " ", s)
298	5x	s. <- gsub(";", " ", s.)
299	5x	tc <- textConnection(s.)
300	5x	x <- scan(tc, quiet = TRUE)
301	5x	close(tc)
302	5x	x
303		}
304
305		# create full matrix based on lower.tri or upper.tri elements; add names
306		# always ROW-WISE!!
307		lav_getcov <- function(x, lower = TRUE, diagonal = TRUE, sds = NULL,
308		names = paste("V", 1:nvar, sep = "")) {
309		# check x and sds
310	3x	if (is.character(x)) x <- lav_char2num(x)
311	2x	if (is.character(sds)) sds <- lav_char2num(sds)
312
313	3x	nels <- length(x)
314	3x	if (lower) {
315	3x	COV <- lav_matrix_lower2full(x, diagonal = diagonal)
316		} else {
317	!	COV <- lav_matrix_upper2full(x, diagonal = diagonal)
318		}
319	3x	nvar <- ncol(COV)
320
321		# if diagonal is false, assume unit diagonal
322	!	if (!diagonal) diag(COV) <- 1
323
324		# check if we have a sds argument
325	3x	if (!is.null(sds)) {
326	2x	stopifnot(length(sds) == nvar)
327	2x	COV <- lav_cor2cov(COV, sds)
328		}
329
330		# names
331	3x	stopifnot(length(names) == nvar)
332	3x	rownames(COV) <- colnames(COV) <- names
333
334	3x	COV
335		}
336
337		lav_char2hash <- function(s = "") {
338	118x	stopifnot(is.character(s))
339	118x	nums <- utf8ToInt(paste(s, collapse = "\n"))
340	118x	rval <- 0x7EDCBA98L
341	118x	for (i in nums) {
342	40969x	positions <- 1L + (bitwAnd(i, 15L))
343	40969x	bitsR <- bitwShiftL(1L, positions) - 1L
344	40969x	wrap1 <- bitwShiftL(bitwAnd(bitsR, rval), 31L - positions)
345	40969x	wrap2 <- bitwShiftR(bitwAnd(bitwNot(bitsR), rval), positions)
346	40969x	saw <- bitwOr(wrap1, wrap2)
347	40969x	rval <- bitwXor(saw, i)
348		}
349	118x	as.hexmode(rval)
350		}
351
352		# vectorize all (h0 or h1) sample statistics, in the same order
353		# as Gamma
354		lav_implied_to_vec <- function(implied = NULL, lavmodel = NULL,
355		drop.list = TRUE) {
356	!	ngroups <- lavmodel@ngroups
357
358	!	wls_obs <- vector("list", ngroups)
359	!	for (g in seq_len(ngroups)) {
360
361	!	var <- NULL
362	!	res.var <- NULL
363	!	if (lavmodel@conditional.x) {
364	!	res.var <- diag(implied$res.cov[[g]])
365	!	res.var <- res.var[res.var != 1]
366		} else {
367	!	var <- diag(implied$cov[[g]])
368	!	var <- var[var != 1]
369		}
370
371	!	wls_obs[[g]] <- lav_samplestats_wls_obs(
372		# plain
373	!	mean.g = implied$mean[[g]],
374	!	cov.g = implied$cov[[g]],
375	!	var.g = var,
376	!	th.g = implied$th[[g]],
377	!	th.idx.g = lavmodel@th.idx[[g]],
378
379		# conditional.x
380	!	res.int.g = implied$res.int[[g]],
381	!	res.cov.g = implied$res.cov[[g]],
382	!	res.var.g = res.var,
383	!	res.th.g = implied$res.th[[g]],
384	!	res.slopes.g = implied$res.slopes[[g]],
385	!	group.w.g = implied$group.w[[g]],
386
387		# flags
388	!	categorical = lavmodel@categorical,
389	!	conditional.x = lavmodel@conditional.x,
390	!	meanstructure = lavmodel@meanstructure,
391	!	correlation = lavmodel@correlation,
392	!	slopestructure = lavmodel@conditional.x,
393	!	group.w.free = lavmodel@group.w.free
394		)
395		}
396
397	!	if (drop.list) {
398	!	out <- unlist(wls_obs)
399		} else {
400	!	out <- wls_obs
401		}
402
403	!	out
404		}
405
406		# given a vector of sample statistics, reconstruct implied
407		# entries (cov, mean, th, res.cov, ...)
408		lav_vec_to_implied <- function(x = NULL, lavmodel) {
409
410	!	ngroups <- lavmodel@ngroups
411	!	implied <- list()
412
413	!	for (g in seq_len(ngroups)) {
414
415		# number of variables
416	!	nvar <- lavmodel@nvar[g]
417
418		# if group.w.free, always comes first
419	!	if (lavmodel@group.w.free) {
420	!	idx <- 1L
421	!	group.w <- x[idx]
422	!	x <- x[-idx]
423		} else {
424	!	group.w <- 1
425		}
426
427	!	if (lavmodel@categorical) {
428		# TODO
429	!	cat("\n NOT READY YET! \n")
430		} else {
431		# diag flag
432	!	diag_flag <- TRUE
433	!	if (lavmodel@correlation) {
434	!	diag_flag <- FALSE
435		}
436	!	if (lavmodel@conditional.x) {
437		# TODO
438	!	cat("\n NOT READY YET! \n")
439		}
440	!	if (lavmodel@meanstructure) {
441	!	idx <- seq_len(nvar)
442	!	mean_g <- x[idx]
443	!	x <- x[-idx]
444		} else {
445	!	mean_g <- numeric(nvar)
446		}
447	!	if (diag_flag) {
448	!	idx <- seq_len( nvar * (nvar + 1) / 2 )
449		} else {
450	!	idx <- seq_len( nvar * (nvar - 1) / 2 )
451		}
452	!	cov_g <- lav_matrix_vech_reverse(x[idx], diagonal = diag_flag)
453	!	x <- x[-idx]
454
455		# fill in
456	!	implied$cov[[g]] <- cov_g
457	!	implied$mean[[g]] <- mean_g
458	!	implied$th[g] <- list(NULL)
459		}
460
461	!	implied$group.w[[g]] <- group.w
462		}
463
464	!	implied
465		}

1		# here, we compute various versions of the `information' matrix
2		# NOTE:
3		# 1) we ALWAYS compute the UNIT information (not the total information)
4		#
5		# 2) by default, we ignore the constraints (we deal with this when we
6		# take the inverse later on)
7
8		lav_model_information <- function(lavmodel = NULL,
9		lavsamplestats = NULL,
10		lavdata = NULL,
11		lavimplied = NULL,
12		lavh1 = NULL,
13		Delta = NULL,
14		lavcache = NULL,
15		lavoptions = NULL,
16		extra = FALSE,
17		augmented = FALSE,
18		inverted = FALSE,
19		use.ginv = FALSE) {
20
21	137x	information <- lavoptions$information[1] # ALWAYS used the first one
22		# caller can control it
23
24		# rotation?
25		# if(!is.null(lavoptions$rotation) && lavoptions$rotation != "none") {
26		# use.ginv <- TRUE
27		# }
28
29	137x	if (is.null(lavh1)) {
30	!	lavh1 <- lav_h1_implied_logl(
31	!	lavdata = lavdata,
32	!	lavsamplestats = lavsamplestats,
33	!	lavoptions = lavoptions
34		)
35		}
36
37		# compute information matrix
38	137x	if (information == "observed") {
39	72x	if (lavsamplestats@missing.flag \|\| lavdata@nlevels > 1L) {
40	68x	group.weight <- FALSE
41		} else {
42	4x	group.weight <- TRUE
43		}
44	72x	E <- lav_model_information_observed(
45	72x	lavmodel = lavmodel,
46	72x	lavsamplestats = lavsamplestats, lavdata = lavdata,
47	72x	lavimplied = lavimplied, lavh1 = lavh1,
48	72x	lavcache = lavcache, group.weight = group.weight,
49	72x	lavoptions = lavoptions, extra = extra,
50	72x	augmented = augmented, inverted = inverted, use.ginv = use.ginv
51		)
52	65x	} else if (information == "expected") {
53	64x	E <- lav_model_information_expected(
54	64x	lavmodel = lavmodel,
55	64x	lavsamplestats = lavsamplestats, lavdata = lavdata,
56	64x	lavimplied = lavimplied, lavh1 = lavh1,
57	64x	lavcache = lavcache, lavoptions = lavoptions, extra = extra,
58	64x	augmented = augmented, inverted = inverted, use.ginv = use.ginv
59		)
60	1x	} else if (information == "first.order") {
61	1x	E <- lav_model_information_firstorder(
62	1x	lavmodel = lavmodel,
63	1x	lavsamplestats = lavsamplestats, lavdata = lavdata,
64	1x	lavimplied = lavimplied, lavh1 = lavh1,
65	1x	lavcache = lavcache, lavoptions = lavoptions, # extra = extra,
66	1x	check.pd = FALSE,
67	1x	augmented = augmented, inverted = inverted, use.ginv = use.ginv
68		)
69		}
70
71		# information, augmented information, or inverted information
72	137x	E
73		}
74
75		# fisher/expected information
76		#
77		# information = Delta' I1 Delta, where I1 is the unit information of
78		# the saturated model (evaluated either at the structured or unstructured
79		# estimates)
80		lav_model_information_expected <- function(lavmodel = NULL,
81		lavsamplestats = NULL,
82		lavdata = NULL,
83		lavoptions = NULL,
84		lavimplied = NULL,
85		lavh1 = NULL,
86		Delta = NULL,
87		lavcache = NULL,
88		extra = FALSE,
89		augmented = FALSE,
90		inverted = FALSE,
91		use.ginv = FALSE) {
92	64x	if (inverted) {
93	64x	augmented <- TRUE
94		}
95
96		# 1. Delta
97	64x	if (is.null(Delta)) {
98	64x	Delta <- lav_model_delta(lavmodel = lavmodel)
99		}
100
101
102		# 2. H1 information (single level)
103	64x	if (lavdata@nlevels == 1L) {
104	64x	A1 <- lav_model_h1_information_expected(
105	64x	lavmodel = lavmodel,
106	64x	lavsamplestats = lavsamplestats,
107	64x	lavdata = lavdata,
108	64x	lavoptions = lavoptions,
109	64x	lavimplied = lavimplied,
110	64x	lavh1 = lavh1,
111	64x	lavcache = lavcache
112		)
113		} else {
114		# force conditional.x = FALSE
115	!	lavimplied <- lav_model_implied_cond2uncond(lavimplied)
116		}
117
118		# 3. compute Information per group
119	64x	Info.group <- vector("list", length = lavsamplestats@ngroups)
120	64x	for (g in 1:lavsamplestats@ngroups) {
121		# note LISREL documentation suggests (Ng - 1) instead of Ng...
122	68x	fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal
123
124		# multilevel
125	68x	if (lavdata@nlevels > 1L) {
126		# here, we assume only 2 levels, at [[1]] and [[2]]
127	!	if (lavoptions$h1.information[1] == "structured") {
128	!	Sigma.W <- lavimplied$cov[[(g - 1) * 2 + 1]]
129	!	Mu.W <- lavimplied$mean[[(g - 1) * 2 + 1]]
130	!	Sigma.B <- lavimplied$cov[[(g - 1) * 2 + 2]]
131	!	Mu.B <- lavimplied$mean[[(g - 1) * 2 + 2]]
132		} else {
133	!	Sigma.W <- lavh1$implied$cov[[(g - 1) * 2 + 1]]
134	!	Mu.W <- lavh1$implied$mean[[(g - 1) * 2 + 1]]
135	!	Sigma.B <- lavh1$implied$cov[[(g - 1) * 2 + 2]]
136	!	Mu.B <- lavh1$implied$mean[[(g - 1) * 2 + 2]]
137		}
138	!	Lp <- lavdata@Lp[[g]]
139
140	!	Info.g <-
141	!	lav_mvnorm_cluster_information_expected_delta(
142	!	Lp = Lp,
143	!	Delta = Delta[[g]],
144	!	Mu.W = Mu.W,
145	!	Sigma.W = Sigma.W,
146	!	Mu.B = Mu.B,
147	!	Sigma.B = Sigma.B,
148	!	Sinv.method = "eigen"
149		)
150	!	Info.group[[g]] <- fg * Info.g
151		} else {
152		# compute information for this group
153	68x	if (lavmodel@estimator %in% c("DWLS", "ULS")) {
154		# diagonal weight matrix
155	4x	Delta2 <- sqrt(A1[[g]]) * Delta[[g]]
156	4x	Info.group[[g]] <- fg * crossprod(Delta2)
157		} else {
158		# full weight matrix
159		# if (lav_use_lavaanC()) {
160		# # (i) use of m_crossprod with sparse matrix on the left:
161		# # Info.group[[g]] <- fg * lavaanC::m_crossprod(Delta[[g]],
162		# # lavaanC::m_prod(A1[[g]], Delta[[g]], "R"), "L")
163		# #
164		# # (ii) use of m_prod on transposed sparse first matrix, faster than (i):
165		# Info.group[[g]] <- fg * lavaanC::m_prod(t(Delta[[g]]),
166		# lavaanC::m_prod(A1[[g]], Delta[[g]], "R"), "L")
167		# } else {
168	64x	Info.group[[g]] <-
169	64x	fg * (crossprod(Delta[[g]], A1[[g]]) %*% Delta[[g]])
170		# }
171		}
172		}
173		} # g
174
175		# 4. assemble over groups
176	64x	Information <- Info.group[[1]]
177	64x	if (lavsamplestats@ngroups > 1) {
178	4x	for (g in 2:lavsamplestats@ngroups) {
179	4x	Information <- Information + Info.group[[g]]
180		}
181		}
182
183		# 5. augmented information?
184	64x	if (augmented) {
185	64x	Information <-
186	64x	lav_model_information_augment_invert(
187	64x	lavmodel = lavmodel,
188	64x	information = Information,
189	64x	inverted = inverted,
190	64x	use.ginv = use.ginv
191		)
192		}
193
194	64x	if (extra) {
195	4x	attr(Information, "Delta") <- Delta
196	4x	attr(Information, "WLS.V") <- A1 # unweighted
197		}
198
199		# possibly augmented/inverted
200	64x	Information
201		}
202
203		# only for Mplus MLM
204		lav_model_information_expected_MLM <- function(lavmodel = NULL,
205		lavsamplestats = NULL,
206		Delta = NULL,
207		extra = FALSE,
208		augmented = FALSE,
209		inverted = FALSE,
210		use.ginv = FALSE) {
211	!	if (inverted) {
212	!	augmented <- TRUE
213		}
214
215	!	if (is.null(Delta)) {
216	!	Delta <- lav_model_delta(lavmodel = lavmodel)
217		}
218
219		# compute A1
220	!	A1 <- vector("list", length = lavsamplestats@ngroups)
221	!	if (lavmodel@group.w.free) {
222	!	GW <- unlist(lav_model_gw(lavmodel = lavmodel))
223		}
224	!	for (g in 1:lavsamplestats@ngroups) {
225	!	A1[[g]] <- lav_mvnorm_h1_information_expected(
226	!	sample.cov = lavsamplestats@cov[[g]],
227	!	sample.cov.inv = lavsamplestats@icov[[g]],
228	!	x.idx = lavsamplestats@x.idx[[g]]
229		)
230		# the same as GLS... (except for the N/N-1 scaling)
231	!	if (lavmodel@group.w.free) {
232		# unweight!!
233	!	a <- exp(GW[g]) / lavsamplestats@nobs[[g]]
234		# a <- exp(GW[g]) * lavsamplestats@ntotal / lavsamplestats@nobs[[g]]
235	!	A1[[g]] <- lav_matrix_bdiag(matrix(a, 1, 1), A1[[g]])
236		}
237		}
238
239		# compute Information per group
240	!	Info.group <- vector("list", length = lavsamplestats@ngroups)
241	!	for (g in 1:lavsamplestats@ngroups) {
242	!	fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal
243		# compute information for this group
244	!	Info.group[[g]] <- fg * (t(Delta[[g]]) %% A1[[g]] %% Delta[[g]])
245		}
246
247		# assemble over groups
248	!	Information <- Info.group[[1]]
249	!	if (lavsamplestats@ngroups > 1) {
250	!	for (g in 2:lavsamplestats@ngroups) {
251	!	Information <- Information + Info.group[[g]]
252		}
253		}
254
255		# augmented information?
256	!	if (augmented) {
257	!	Information <-
258	!	lav_model_information_augment_invert(
259	!	lavmodel = lavmodel,
260	!	information = Information,
261	!	inverted = inverted,
262	!	use.ginv = use.ginv
263		)
264		}
265
266	!	if (extra) {
267	!	attr(Information, "Delta") <- Delta
268	!	attr(Information, "WLS.V") <- A1 # unweighted
269		}
270
271	!	Information
272		}
273
274
275		lav_model_information_observed <- function(lavmodel = NULL,
276		lavsamplestats = NULL,
277		lavdata = NULL,
278		lavimplied = NULL,
279		lavh1 = NULL,
280		lavcache = NULL,
281		lavoptions = NULL,
282		extra = FALSE,
283		group.weight = TRUE,
284		augmented = FALSE,
285		inverted = FALSE,
286		use.ginv = FALSE) {
287	72x	if (inverted) {
288	72x	augmented <- TRUE
289		}
290
291		# observed.information:
292		# - "hessian": second derivative of objective function
293		# - "h1": observed information matrix of saturated (h1) model,
294		# pre- and post-multiplied by the jacobian of the model
295		# parameters (Delta), usually evaluated at the structured
296		# sample statistics (but this depends on the h1.information
297		# option)
298	72x	if (!is.null(lavoptions) &&
299	72x	!is.null(lavoptions$observed.information[1]) &&
300	72x	lavoptions$observed.information[1] == "h1") {
301	48x	observed.information <- "h1"
302		} else {
303	24x	observed.information <- "hessian"
304		}
305
306		# HESSIAN based
307	72x	if (observed.information == "hessian") {
308	24x	Hessian <- lav_model_hessian(
309	24x	lavmodel = lavmodel,
310	24x	lavsamplestats = lavsamplestats,
311	24x	lavdata = lavdata,
312	24x	lavoptions = lavoptions,
313	24x	lavcache = lavcache,
314	24x	group.weight = group.weight,
315	24x	ceq.simple = FALSE
316		)
317
318		# NOTE! What is the relationship between the Hessian of the objective
319		# function, and the `information' matrix (unit or total)
320
321		# 1. in lavaan, we ALWAYS minimize, so the Hessian is already pos def
322		# 2. currently, all estimators give unit information, except MML and PML
323		# so, no need to divide by N
324	24x	Information <- Hessian
325
326		# divide by 'N' for MML and PML
327	24x	if (lavmodel@estimator == "PML" \|\| lavmodel@estimator == "MML") {
328	!	Information <- Information / lavsamplestats@ntotal
329		# HJ: Does this need to be divided by sum of weights instead?
330		}
331
332		# if multilevel, we should divide by 'J', the number of clusters
333	24x	if (lavdata@nlevels > 1L) {
334	4x	NC <- 0
335	4x	for (g in 1:lavsamplestats@ngroups) {
336	8x	NC <- NC + lavdata@Lp[[g]]$nclusters[[2]]
337		}
338	4x	Information <- Information * lavsamplestats@ntotal / NC
339		}
340		}
341
342		# using 'observed h1 information'
343		# we need DELTA and 'WLS.V' (=A1)
344
345	72x	if (observed.information == "h1" \|\| extra) {
346		# 1. Delta
347	48x	Delta <- lav_model_delta(lavmodel = lavmodel)
348
349		# 2. H1 information
350
351	48x	A1 <- lav_model_h1_information_observed(
352	48x	lavmodel = lavmodel,
353	48x	lavsamplestats = lavsamplestats,
354	48x	lavdata = lavdata,
355	48x	lavoptions = lavoptions,
356	48x	lavimplied = lavimplied,
357	48x	lavh1 = lavh1,
358	48x	lavcache = lavcache
359		)
360		}
361
362	72x	if (observed.information == "h1") {
363		# compute Information per group
364	48x	Info.group <- vector("list", length = lavsamplestats@ngroups)
365	48x	for (g in 1:lavsamplestats@ngroups) {
366	48x	fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal
367		# compute information for this group
368	48x	if (lavmodel@estimator %in% c("DWLS", "ULS")) {
369		# diagonal weight matrix
370	!	Delta2 <- sqrt(A1[[g]]) * Delta[[g]]
371	!	Info.group[[g]] <- fg * crossprod(Delta2)
372		} else {
373		# full weight matrix
374	48x	Info.group[[g]] <-
375	48x	fg * (crossprod(Delta[[g]], A1[[g]]) %*% Delta[[g]])
376		}
377		}
378
379		# assemble over groups
380	48x	Information <- Info.group[[1]]
381	48x	if (lavsamplestats@ngroups > 1) {
382	!	for (g in 2:lavsamplestats@ngroups) {
383	!	Information <- Information + Info.group[[g]]
384		}
385		}
386		}
387
388		# augmented information?
389	72x	if (augmented) {
390	72x	Information <-
391	72x	lav_model_information_augment_invert(
392	72x	lavmodel = lavmodel,
393	72x	information = Information,
394	72x	inverted = inverted,
395	72x	use.ginv = use.ginv
396		)
397		}
398
399	72x	if (extra) {
400	!	attr(Information, "Delta") <- Delta
401	!	attr(Information, "WLS.V") <- A1
402		}
403
404	72x	Information
405		}
406
407		# outer product of the case-wise scores (gradients)
408		# HJ 18/10/23: Need to divide sum of crossproduct of individual log-likelihoods
409		# by sum of weights rather than sample size.
410		lav_model_information_firstorder <- function(lavmodel = NULL,
411		lavsamplestats = NULL,
412		lavdata = NULL,
413		lavimplied = NULL,
414		lavh1 = NULL,
415		lavcache = NULL,
416		lavoptions = NULL,
417		check.pd = FALSE,
418		extra = FALSE,
419		augmented = FALSE,
420		inverted = FALSE,
421		use.ginv = FALSE) {
422	9x	if (!lavmodel@estimator %in% c("ML", "PML")) {
423	!	lav_msg_stop(gettext(
424	!	"information = \"first.order\" not available for estimator"),
425	!	sQuote(lavmodel@estimator))
426		}
427
428	9x	if (inverted) {
429	!	augmented <- TRUE
430		}
431
432	9x	B0.group <- vector("list", lavsamplestats@ngroups)
433
434		# 1. Delta
435	9x	Delta <- lav_model_delta(lavmodel = lavmodel)
436
437		# 2. H1 information
438	9x	B1 <- lav_model_h1_information_firstorder(
439	9x	lavmodel = lavmodel,
440	9x	lavsamplestats = lavsamplestats,
441	9x	lavdata = lavdata,
442	9x	lavoptions = lavoptions,
443	9x	lavimplied = lavimplied,
444	9x	lavh1 = lavh1,
445	9x	lavcache = lavcache
446		)
447
448		# 3. compute Information per group
449	9x	Info.group <- vector("list", length = lavsamplestats@ngroups)
450	9x	for (g in 1:lavsamplestats@ngroups) {
451		# unweighted (needed in lav_test?)
452	9x	B0.group[[g]] <- t(Delta[[g]]) %% B1[[g]] %% Delta[[g]]
453
454		# >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
455
456		# NOTE: UNSURE ABOUT THIS PART. WHAT IS THE ROLE OF fg?
457
458	9x	wt <- lavdata@weights[[g]]
459	9x	if (is.null(wt)) {
460	9x	fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal
461		} else {
462	!	totalwt <- sum(unlist(lavdata@weights))
463	!	fg <- sum(wt) / totalwt
464		}
465
466		# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
467
468		# compute information for this group
469	9x	Info.group[[g]] <- fg * B0.group[[g]]
470		}
471
472		# 4. assemble over groups
473	9x	Information <- Info.group[[1]]
474	9x	if (lavsamplestats@ngroups > 1) {
475	!	for (g in 2:lavsamplestats@ngroups) {
476	!	Information <- Information + Info.group[[g]]
477		}
478		}
479
480		# NOTE: for MML and PML, we get 'total' information (instead of unit) divide
481		# by 'N' for MML and PML. For weighted sample, use the sum of weights
482		# instead of sample size
483
484		# >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
485
486	9x	if (lavmodel@estimator == "PML" \|\| lavmodel@estimator == "MML") {
487	!	if (length(lavdata@sampling.weights) == 0) {
488	!	the_N <- lavsamplestats@ntotal
489		} else {
490	!	the_N <- sum(unlist(lavdata@weights))
491		}
492	!	Information <- Information / the_N
493	!	for (g in 1:lavsamplestats@ngroups) {
494	!	B0.group[[g]] <- B0.group[[g]] / the_N
495		}
496		}
497		# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
498
499		# augmented information?
500	9x	if (augmented) {
501	!	Information <-
502	!	lav_model_information_augment_invert(
503	!	lavmodel = lavmodel,
504	!	information = Information,
505	!	check.pd = check.pd,
506	!	inverted = inverted,
507	!	use.ginv = use.ginv
508		)
509		}
510
511	9x	if (extra) {
512	8x	attr(Information, "B0.group") <- B0.group
513	8x	attr(Information, "Delta") <- Delta
514	8x	attr(Information, "WLS.V") <- B1
515		}
516
517	9x	Information
518		}
519
520
521		# create augmented information matrix (if needed), and take the inverse
522		# (if inverted = TRUE), returning only the [1:npar, 1:npar] elements
523		#
524		# rm.idx is used by lav_sam_step2_se; it used when the structural model
525		# contains more parameters than the joint model; therefore, information
526		# will be 'too small', and we need to remove some columns in H
527		#
528		lav_model_information_augment_invert <- function(lavmodel = NULL,
529		information = NULL,
530		inverted = FALSE,
531		check.pd = FALSE,
532		use.ginv = FALSE,
533		rm.idx = integer(0L)) {
534	136x	npar <- nrow(information)
535	136x	is.augmented <- FALSE
536
537		# handle constraints
538	136x	if (nrow(lavmodel@con.jac) > 0L) {
539	90x	H <- lavmodel@con.jac
540	90x	if (length(rm.idx) > 0L) {
541	!	H <- H[, -rm.idx, drop = FALSE]
542		}
543	90x	inactive.idx <- attr(H, "inactive.idx")
544	90x	lambda <- lavmodel@con.lambda # lagrangean coefs
545	90x	if (length(inactive.idx) > 0L) {
546	80x	H <- H[-inactive.idx, , drop = FALSE]
547	80x	lambda <- lambda[-inactive.idx]
548		}
549	90x	if (nrow(H) > 0L) {
550	15x	is.augmented <- TRUE
551	15x	H0 <- matrix(0, nrow(H), nrow(H))
552	15x	H10 <- matrix(0, ncol(information), nrow(H))
553	15x	DL <- 2 * diag(lambda, nrow(H), nrow(H))
554		# FIXME: better include inactive + slacks??
555		# INFO <- information
556		# or
557	15x	INFO <- information + crossprod(H)
558	15x	E3 <- rbind(
559	15x	cbind(INFO, H10, t(H)),
560	15x	cbind(t(H10), DL, H0),
561	15x	cbind(H, H0, H0)
562		)
563	15x	information <- E3
564		}
565	46x	} else if (lavmodel@ceq.simple.only) {
566	!	H <- t(lav_matrix_orthogonal_complement(lavmodel@ceq.simple.K))
567	!	if (length(rm.idx) > 0L) {
568	!	H <- H[, -rm.idx, drop = FALSE]
569		}
570	!	if (nrow(H) > 0L) {
571	!	is.augmented <- TRUE
572	!	H0 <- matrix(0, nrow(H), nrow(H))
573	!	H10 <- matrix(0, ncol(information), nrow(H))
574	!	INFO <- information + crossprod(H)
575	!	E2 <- rbind(
576	!	cbind(INFO, t(H)),
577	!	cbind(H, H0)
578		)
579	!	information <- E2
580		}
581		}
582
583	136x	if (check.pd) {
584	!	eigvals <- eigen(information,
585	!	symmetric = TRUE,
586	!	only.values = TRUE
587	!	)$values
588	!	if (any(eigvals < -1 * .Machine$double.eps^(3 / 4))) {
589	!	lav_msg_warn(gettext(
590	!	"information matrix is not positive definite;
591	!	the model may not be identified"))
592		}
593		}
594
595	136x	if (inverted) {
596	136x	if (is.augmented) {
597		# note: default tol in MASS::ginv is sqrt(.Machine$double.eps)
598		# which seems a bit too conservative
599		# from 0.5-20, we changed this to .Machine$double.eps^(3/4)
600	15x	information <-
601	15x	try(
602	15x	MASS::ginv(information,
603	15x	tol = .Machine$double.eps^(3 / 4)
604	15x	)[1:npar,
605	15x	1:npar,
606	15x	drop = FALSE
607		],
608	15x	silent = TRUE
609		)
610		} else {
611	121x	if (use.ginv) {
612	!	information <- try(
613	!	MASS::ginv(information,
614	!	tol = .Machine$double.eps^(3 / 4)
615		),
616	!	silent = TRUE
617		)
618		} else {
619	121x	information <- try(solve(information), silent = TRUE)
620		}
621		}
622		}
623
624		# augmented/inverted information
625	136x	information
626		}
627
628		lav_model_information_expected_2l <- function(lavmodel = NULL,
629		lavsamplestats = NULL,
630		lavdata = NULL,
631		lavoptions = NULL,
632		lavimplied = NULL,
633		lavh1 = NULL,
634		g = 1L) {
635		# see Yuan & Bentler (2002), p.549 top line
636		# I.j = nj. Delta.mu' sigma.j.inv +
637		# Delta.sigma.j' W.j Delta.sigma.j +
638		# (nj-1) Delta.sigma.w' W.w Delta.sigma.w
639		#
640		# where
641		# - sigma.j = sigma.w + n.j * sigma.b
642		# - W.w = 1/2 * D'(sigma.w.inv %x% sigma.w.inv) D
643		# - W.j = 1/2 * D'(sigma.j.inv %x% sigma.j.inv) D
644		}

1		lav_lavaan_step01_ovnames_initflat <- function(slotParTable = NULL, # nolint
2		model = NULL,
3		dotdotdot.parser = "new") {
4		# if slotPartable not NULL copy to flat.model
5		# else
6		# if model is of type character
7		# parse model to flat.model
8		# else if model is a formula ( warning )
9		# transform "~ x1 + x2 + x3" to character "f =~ x1 + x2 + x3",
10		# and parse to flat.model
11		# transform "y =~ x1 + x2 + x3" to character and parse to flat.model
12		# something else : * error *
13		# else if model is a lavaan object
14		# extract flat.model from @parTable
15		# else if model is a list
16		# if bare minimum present (columns lhs, op, rhs, free)
17		# flat.model = model
18		# replace column block by column group (if present)
19		# else
20		# --> * error *
21		# else
22		# --> *error*
23		#
24
25		# 1a. get ov.names and ov.names.x (per group) -- needed for lav_lavdata()
26	140x	if (!is.null(slotParTable)) {
27	!	flat.model <- slotParTable
28	140x	} else if (is.character(model)) {
29	47x	if (is.null(dotdotdot.parser)) {
30	!	flat.model <- lavParseModelString(model, parser = "new")
31		} else {
32	47x	flat.model <- lavParseModelString(model, parser = dotdotdot.parser)
33		}
34	93x	} else if (inherits(model, "formula")) {
35		# two typical cases:
36		# 1. regression type formula
37		# 2. no quotes, e.g. f =~ x1 + x2 + x3
38		# TODO: this isn't a valid formula !!!
39	!	tmp <- as.character(model)
40	!	if (tmp[1] == "~" && length(tmp) == 2L) {
41		# looks like an unquoted single factor model f =~ something
42	!	lav_msg_warn(
43	!	gettext("model seems to be a formula;
44	!	please enclose the model syntax between quotes"))
45		# create model and hope for the best
46	!	model.bis <- paste("f =", paste(tmp, collapse = " "), sep = "")
47	!	flat.model <- lavParseModelString(model.bis)
48	!	} else if (tmp[1] == "~" && length(tmp) == 3L) {
49		# looks like a (unquoted) regression formula
50	!	lav_msg_warn(
51	!	gettext("model seems to be a formula;
52	!	please enclose the model syntax between quotes"))
53		# create model and hope for the best
54	!	model.bis <- paste(tmp[2], tmp[1], tmp[3])
55	!	flat.model <- lavParseModelString(model.bis)
56		} else {
57	!	lav_msg_stop(
58	!	gettext("model seems to be a formula;
59	!	please enclose the model syntax between quotes"))
60		}
61	93x	} else if (inherits(model, "lavaan")) {
62		# hm, a lavaan model; let's try to extract the parameter table
63		# and see what happens
64	!	flat.model <- parTable(model)
65	93x	} else if (is.list(model)) {
66		# a list! perhaps a full parameter table, or an initial flat model,
67		# or something else...
68
69		# 1. flat.model already (output of lavParseModelString)?
70	93x	if (!is.null(model$lhs) && !is.null(model$op) &&
71	93x	!is.null(model$rhs) && !is.null(model$mod.idx) &&
72	93x	!is.null(attr(model, "modifiers"))) {
73	!	flat.model <- model
74		}
75
76		# look for the bare minimum columns: lhs - op - rhs
77	93x	else if (!is.null(model$lhs) && !is.null(model$op) &&
78	93x	!is.null(model$rhs) && !is.null(model$free)) {
79		# ok, we have something that looks like a parameter table
80	93x	flat.model <- model
81
82		# fix semTools issue here? for auxiliary() which does not use
83		# block column yet
84	93x	if (!is.null(flat.model$block)) {
85	93x	nn <- length(flat.model$lhs)
86	93x	if (length(flat.model$block) != nn) {
87	!	flat.model$block <- flat.model$group
88		}
89	93x	if (any(is.na(flat.model$block))) {
90	!	flat.model$block <- flat.model$group
91		}
92	!	} else if (!is.null(flat.model$group)) {
93	!	flat.model$block <- flat.model$group
94		}
95		} else {
96	!	bare.minimum <- c("lhs", "op", "rhs", "free")
97	!	missing.idx <- is.na(match(bare.minimum, names(model)))
98	!	lav_msg_stop(
99	!	gettextf("model is a list, but not a parameterTable?
100	!	missing column(s) in parameter table: [%s]",
101	!	lav_msg_view(bare.minimum[missing.idx], "none")))
102		}
103		} else {
104	!	lav_msg_stop(gettext("model is NULL or not a valid type for it!"))
105		}
106
107		# Ok, we got a flattened model; usually this a flat.model object, but it
108		# could also be an already lavaanified parTable, or a bare-minimum list with
109		# lhs/op/rhs/free elements
110	140x	flat.model
111		}
112
113		# this function is only needed for backwards compatibility: it falls back
114		# to the old (<0.6-20) way of handling composites (defined by the '<~' operator)
115		# we do this by substituting the '<~' operator by '~', and by creating
116		# phantom latent variables for the LHS, and setting the residual variance
117		# to zero
118		#
119		# For example: "f <~ 1*income + occup + educ" is replaced by:
120		# "f =~ 0; f ~~ 0f; f ~ 1income + occup + educ"
121		#
122		lav_lavaan_step01_ovnames_composites <- function(flat.model = NULL) { # nolint
123
124		# get composite idx
125	!	c.idx <- which(flat.model$op == "<~")
126	!	if (length(c.idx) == 0L) {
127	!	return(flat.model)
128		}
129
130		# flat.model info
131	!	nel <- length(flat.model$lhs)
132	!	flat.names <- names(flat.model)
133	!	c.names <- unique(flat.model$lhs[c.idx])
134	!	nc <- length(c.names)
135	!	mod.val <- max(flat.model$mod.idx)
136
137		# check block numbers
138	!	max.block <- max(flat.model$block)
139	!	if (max.block > 1L) {
140	!	lav_msg_stop(gettext("composites = FALSE is not support when multiple blocks are supported; manually replace f <~ rhs by f =~ 0; f ~~ 0*f; f ~ rhs"))
141		}
142
143	!	block <- 1L
144
145		# replace '<~' by '~'
146	!	flat.model$op[c.idx] <- "~"
147
148		# add phantom latent variables
149	!	flat.model$lhs <- c(flat.model$lhs, c.names)
150	!	flat.model$op <- c(flat.model$op, rep("=~", nc))
151	!	flat.model$rhs <- c(flat.model$rhs, c.names)
152	!	flat.model$fixed <- c(flat.model$fixed, rep("", nc))
153	!	flat.model$mod.idx <- c(flat.model$mod.idx, rep(0L, nc))
154	!	flat.model$block <- c(flat.model$block, rep(block, nc))
155
156		# fix residual variances
157	!	flat.model$lhs <- c(flat.model$lhs, c.names)
158	!	flat.model$op <- c(flat.model$op, rep("~~", nc))
159	!	flat.model$rhs <- c(flat.model$rhs, c.names)
160	!	flat.model$fixed <- c(flat.model$fixed, rep("0", nc)) # just for show
161	!	flat.model$mod.idx <- c(flat.model$mod.idx, mod.val + seq_len(nc))
162	!	flat.model$block <- c(flat.model$block, rep(block, nc))
163
164		# extend the 'other' columns
165	!	other <- flat.names[!flat.names %in% c("lhs", "op", "rhs",
166	!	"fixed", "mod.idx", "block")]
167	!	for (o in other) {
168	!	if (is.character(flat.model[[o]])) {
169	!	flat.model[[o]] <- c(flat.model[[o]], rep("", nc*2))
170	!	} else if(is.integer(flat.model[[o]])) {
171	!	flat.model[[o]] <- c(flat.model[[o]], rep(0L, nc*2))
172		} else {
173	!	flat.model[[o]] <- c(flat.model[[o]], rep(as.numeric(NA), nc*2))
174		}
175		}
176
177		# add fixed values to the modifier attribute
178	!	attr(flat.model, "modifiers") <- c(attr(flat.model, "modifiers"),
179	!	rep(list(list(fixed = 0)), nc))
180
181	!	flat.model
182		}
183
184		lav_lavaan_step01_ovnames_ovorder <- function(flat.model = NULL, # nolint
185		ov.order = "model",
186		data = NULL,
187		sample.cov = NULL,
188		slotData = NULL) { # nolint
189		# set ov.order in lowercase, check if it is "data" or "model",
190		# if not * error *
191		# if ov.order == "data"
192		# try adapt flat.model via lav_partable_ov_from_data
193		# ( warning if this fails)
194
195		# new in 0.6-14
196		# if ov.order = "data", it would seem we need to intervene here;
197		# ldw 1/3/2024:
198		# we do this by adding an attribute "ovda" to flat.model and partable
199	140x	ov.order <- tolower(ov.order)
200	140x	if (ov.order == "data") {
201	2x	flat.model.orig <- flat.model
202	2x	try(
203	2x	flat.model <- lav_partable_ov_from_data(flat.model,
204	2x	data = data,
205	2x	sample.cov = sample.cov,
206	2x	slotData = slotData
207		),
208	2x	silent = TRUE
209		)
210	2x	if (inherits(flat.model, "try-error")) {
211	!	lav_msg_warn(gettext("ov.order = \"data\" setting failed;
212	!	switching back to ov.order = \"model\""))
213	!	flat.model <- flat.model.orig
214		}
215	138x	} else if (ov.order != "model") {
216	!	lav_msg_stop(gettext(
217	!	"ov.order= argument should be \"model\" (default) or \"data\""))
218		}
219
220	140x	flat.model
221		}
222
223		lav_lavaan_step01_ovnames_group <- function(flat.model = NULL, # nolint
224		ngroups = 1L) {
225		# if "group :" appears in flat.model
226		# tmp.group.values: set of names in corresponding right hand sides
227		# copy flat.model without attributes and call lav_model_partable,
228		# store result in tmp.lav
229		# extract ov.names, ov.names.y, ov.names.x, lv.names from tmp.lav
230		# via lav_partable_vnames
231		# else
232		# if flat.model$group not NULL and more then 1 group.value
233		# extract group.values via lav_partable_group_values
234		# extract, for each group.value,
235		# ov.names, ov.names.y, ov.names.x, lv.names from flat.model
236		# via lav_partable_vnames
237		# else
238		# extract ov.names, ov.names.y, ov.names.x, lv.names from flat.model
239		# via lav_partable_vnames
240		#
241		# TODO: call lav_partable_vnames only ones and not for each type
242
243	140x	flat.model.2 <- NULL
244	140x	tmp.lav <- NULL
245	140x	group.values <- NULL
246	140x	ov.names <- character(0L)
247	140x	if (any(flat.model$op == ":" & tolower(flat.model$lhs) == "group")) {
248		# here, we only need to figure out:
249		# - ngroups
250		# - ov's per group
251		#
252		# - FIXME: we need a more efficient way, avoiding
253		# lav_model_partable/lav_partable_vnames
254		#
255	2x	group.idx <- which(flat.model$op == ":" &
256	2x	tolower(flat.model$lhs) == "group")
257		# replace by 'group' (in case we got 'Group'):
258	2x	flat.model$lhs[group.idx] <- "group"
259	2x	tmp.group.values <- unique(flat.model$rhs[group.idx])
260	2x	tmp.ngroups <- length(tmp.group.values)
261
262	2x	flat.model.2 <- flat.model
263	2x	attr(flat.model.2, "modifiers") <- NULL
264	2x	attr(flat.model.2, "constraints") <- NULL
265	2x	tmp.lav <- lav_model_partable(flat.model.2, ngroups = tmp.ngroups, warn = FALSE)
266	2x	ov.names <- ov.names.y <- ov.names.x <- lv.names <- vector("list",
267	2x	length = tmp.ngroups
268		)
269	2x	attr(tmp.lav, "vnames") <- lav_partable_vnames(tmp.lav, type = "*")
270	2x	for (g in seq_len(tmp.ngroups)) {
271	4x	ov.names[[g]] <- unique(unlist(lav_partable_vnames(tmp.lav,
272	4x	type = "ov", group = tmp.group.values[g]
273		)))
274	4x	ov.names.y[[g]] <- unique(unlist(lav_partable_vnames(tmp.lav,
275	4x	type = "ov.nox", group = tmp.group.values[g]
276		)))
277	4x	ov.names.x[[g]] <- unique(unlist(lav_partable_vnames(tmp.lav,
278	4x	type = "ov.x", group = tmp.group.values[g]
279		)))
280	4x	lv.names[[g]] <- unique(unlist(lav_partable_vnames(tmp.lav,
281	4x	type = "lv", group = tmp.group.values[g]
282		)))
283		}
284	138x	} else if (!is.null(flat.model$group)) {
285		# user-provided full partable with group column!
286	93x	attr(flat.model, "vnames") <- lav_partable_vnames(flat.model, type = "*")
287	93x	ngroups <- lav_partable_ngroups(flat.model)
288	93x	if (ngroups > 1L) {
289	4x	group.values <- lav_partable_group_values(flat.model)
290	4x	ov.names <- ov.names.y <- ov.names.x <- lv.names <- vector("list",
291	4x	length = ngroups
292		)
293	4x	for (g in seq_len(ngroups)) {
294		# collapsed over levels (if any)
295	8x	ov.names[[g]] <- unique(unlist(lav_partable_vnames(flat.model,
296	8x	type = "ov", group = group.values[g]
297		)))
298	8x	ov.names.y[[g]] <- unique(unlist(lav_partable_vnames(flat.model,
299	8x	type = "ov.nox", group = group.values[g]
300		)))
301	8x	ov.names.x[[g]] <- unique(unlist(lav_partable_vnames(flat.model,
302	8x	type = "ov.x", group = group.values[g]
303		)))
304	8x	lv.names[[g]] <- unique(unlist(lav_partable_vnames(flat.model,
305	8x	type = "lv", group = group.values[g]
306		)))
307		}
308		} else {
309	89x	ov.names <- lav_partable_vnames(flat.model, type = "ov")
310	89x	ov.names.y <- lav_partable_vnames(flat.model, type = "ov.nox")
311	89x	ov.names.x <- lav_partable_vnames(flat.model, type = "ov.x")
312	89x	lv.names <- lav_partable_vnames(flat.model, type = "lv")
313		}
314		} else {
315		# collapse over levels (if any)
316	45x	attr(flat.model, "vnames") <- lav_partable_vnames(flat.model, type = "*")
317	45x	ov.names <- unique(unlist(lav_partable_vnames(flat.model, type = "ov")))
318	45x	ov.names.y <- unique(unlist(lav_partable_vnames(flat.model,
319	45x	type = "ov.nox")))
320	45x	ov.names.x <- unique(unlist(lav_partable_vnames(flat.model, type = "ov.x")))
321	45x	lv.names <- unique(unlist(lav_partable_vnames(flat.model, type = "lv")))
322		}
323
324		# sanity check (new in 0.6-8): do we have any ov.names?
325		# detect early
326	140x	if (length(unlist(ov.names)) == 0L) {
327	!	lav_msg_stop(
328	!	gettext("ov.names is empty: model does not refer to any observed
329	!	variables; check your syntax."))
330		}
331
332	140x	list(
333	140x	flat.model = flat.model,
334	140x	ov.names = ov.names,
335	140x	ov.names.x = ov.names.x,
336	140x	ov.names.y = ov.names.y,
337	140x	lv.names = lv.names,
338	140x	group.values = group.values,
339	140x	ngroups = ngroups
340		)
341		}
342
343		lav_lavaan_step01_ovnames_checklv <- function( # nolint
344		lv.names = character(0L),
345		ov.names = character(0L),
346		data = NULL,
347		sample.cov = NULL,
348		dotdotdot = NULL,
349		slotOptions = NULL) { # nolint
350
351		# latent variable names should not appear in the subset of the data
352		# that is formed by merging ov+lv names --> warning
353		# latent interactions are not supported ---> * error *
354
355	140x	if (is.null(data) && is.null(sample.cov)) {
356	63x	return(invisible(NULL))
357		}
358
359		# handle for lv.names that are also observed variables (new in 0.6-6)
360	77x	lv.lv.names <- unique(unlist(lv.names))
361	77x	ov.ov.names <- unique(unlist(ov.names))
362	77x	if (length(lv.lv.names) > 0L) {
363
364		# get data-based variable names
365	29x	data_names <- character(0L)
366	29x	if (!is.null(data)) {
367	21x	data_names <- names(data)
368	8x	} else if (!is.null(sample.cov)) {
369	8x	data_names <- rownames(sample.cov)
370		}
371
372		# create subset of variable names, based on the model
373	29x	model_names <- unique(c(ov.ov.names, lv.lv.names))
374	29x	subset_names <- data_names[data_names %in% model_names]
375	29x	bad.idx <- which(lv.lv.names %in% subset_names)
376
377	29x	if (length(bad.idx) > 0L) {
378	!	if (!is.null(dotdotdot$check.lv.names) &&
379	!	!dotdotdot$check.lv.names) {
380		# ignore it, user switched this check off -- new in 0.6-7
381		} else {
382	!	lav_msg_warn(gettextf(
383	!	"Some latent variable names collide with observed variable names in
384	!	the dataset: %s. Please provide alternative names for the latent
385	!	variables, or switch off this check using check.lv.names = FALSE",
386	!	paste(lv.lv.names[bad.idx], collapse = " "))
387		)
388		}
389		}
390		}
391
392		# sanity check: we do not support latent interaction yet (using the :)
393	77x	lv.int.idx <- which(grepl(":", lv.lv.names))
394	77x	if (length(lv.int.idx) > 0L) {
395	!	if (!is.null(dotdotdot$check.lv.interaction) &&
396	!	!dotdotdot$check.lv.interaction) {
397		# ignore, user (or sam) switched this check off - new in 0.6-16
398	!	} else if (!is.null(slotOptions) && !slotOptions$check.lv.interaction) {
399		# ignore
400		} else {
401	!	lav_msg_stop(gettextf(
402	!	"Interaction terms involving latent variables (%s) are not supported.
403	!	Either use the sam() function, or consider using the modsem package.",
404	!	lv.lv.names[lv.int.idx[1]]))
405		}
406		}
407
408	77x	invisible(NULL)
409		}
410
411		lav_lavaan_step01_ovnames_namesl <- function(data = NULL, # nolint
412		cluster = NULL,
413		flat.model = NULL,
414		group.values = NULL,
415		ngroups = 1L) {
416		# if "level :" appears in flat.model
417		# if data not NULL, cluster must not be NULL, if it is: * error *
418		# compute tmp.group.values and tmp.level.values from flat.model
419		# there should be at least 2 levels, if not * error *
420		# copy flat.model without attributes and lav_model_partable -> tmp.lav
421		# check at least 2 levels for tmp.lav, if not * error *
422		# compute ov.names.l per group and per level (via lav_partable_vnames
423		# on tmp.lav)
424		# else
425		# if lav_partable_nlevels(flat.model) > 0
426		# if data not NULL, cluster must not be NULL, if it is: * error *
427		# compute ov.names.l per group and per level (via lav_partable_vnames
428		# on flat.model)
429		# else
430		# there are no levels (ov.names.l = list())
431
432		# handle ov.names.l
433	140x	if (any(flat.model$op == ":" & tolower(flat.model$lhs) == "level")) {
434		# check for cluster argument
435	2x	if (!is.null(data) && is.null(cluster)) {
436	!	lav_msg_stop(gettext("cluster argument is missing."))
437		}
438
439		# here, we only need to figure out:
440		# - nlevels
441		# - ov's per level
442		# - FIXME: we need a more efficient way, avoiding lav_model_partable/vnames
443
444	2x	group.idx <- which(flat.model$op == ":" & flat.model$lhs == "group")
445	2x	tmp.group.values <- unique(flat.model$rhs[group.idx])
446	2x	tmp.ngroups <- max(c(length(tmp.group.values), 1))
447
448	2x	level.idx <- which(flat.model$op == ":" &
449	2x	tolower(flat.model$lhs) == "level")
450		# replace by "level" (in case we got 'Level')
451	2x	flat.model$lhs[level.idx] <- "level"
452	2x	tmp.level.values <- unique(flat.model$rhs[level.idx])
453	2x	tmp.nlevels <- length(tmp.level.values)
454
455		# we need at least 2 levels (for now)
456	2x	if (tmp.nlevels < 2L) {
457	!	lav_msg_stop(
458	!	gettext("when data is clustered, you must specify a model
459	!	for each level in the model syntax (for now);
460	!	see example(Demo.twolevel)")
461		)
462		}
463
464	2x	flat.model.2 <- flat.model
465	2x	attr(flat.model.2, "modifiers") <- NULL
466	2x	attr(flat.model.2, "constraints") <- NULL
467	2x	tmp.lav <- lav_model_partable(flat.model.2, ngroups = tmp.ngroups, warn = FALSE)
468		# check for empty levels
469	2x	if (max(tmp.lav$level) < 2L) {
470	!	lav_msg_stop(
471	!	gettext("at least one level has no model syntax;
472	!	you must specify a model for each level in the model syntax;
473	!	see example(Demo.twolevel)")
474		)
475		}
476	2x	ov.names.l <- vector("list", length = tmp.ngroups) # per group
477
478	2x	for (g in seq_len(tmp.ngroups)) {
479	4x	ov.names.l[[g]] <- vector("list", length = tmp.nlevels)
480	4x	for (l in seq_len(tmp.nlevels)) {
481	8x	if (tmp.ngroups > 1L) {
482	8x	ov.names.l[[g]][[l]] <-
483	8x	unique(unlist(lav_partable_vnames(tmp.lav,
484	8x	type = "ov",
485	8x	group = tmp.group.values[g],
486	8x	level = tmp.level.values[l]
487		)))
488		} else {
489	!	ov.names.l[[g]][[l]] <-
490	!	unique(unlist(lav_partable_vnames(tmp.lav,
491	!	type = "ov",
492	!	level = tmp.level.values[l]
493		)))
494		}
495		} # levels
496		} # groups
497		} else {
498		# perhaps model is already a parameter table
499	138x	nlevels <- lav_partable_nlevels(flat.model)
500	138x	if (nlevels > 1L) {
501		# check for cluster argument (only if we have data)
502	2x	if (!is.null(data) && is.null(cluster)) {
503	!	lav_msg_stop(gettext("cluster argument is missing."))
504		}
505
506	2x	ngroups <- lav_partable_ngroups(flat.model)
507	2x	group.values <- lav_partable_group_values(flat.model)
508	2x	ov.names.l <- vector("list", length = ngroups)
509	2x	for (g in 1:ngroups) {
510		# note: lav_object_vnames() will return a list if any level:
511	4x	ov.names.l[[g]] <- lav_object_vnames(flat.model, "ov", group = group.values[g])
512		}
513		} else {
514		# no level: in model syntax
515	136x	ov.names.l <- list()
516		}
517		}
518
519	140x	list(
520	140x	flat.model = flat.model,
521	140x	ov.names.l = ov.names.l
522		)
523		}
524
525		lav_lavaan_step01_ovnames_ordered <- function(ordered = NULL, # nolint
526		flat.model = NULL,
527		data = NULL) {
528		# interpretation and check ordered parameter, modify if needed
529
530		# sanity check ordered argument (just in case, add lhs variables names)
531	140x	if (!is.null(ordered)) { # new in 0.6-4
532	2x	if (is.logical(ordered) && ordered) { # ordered = TRUE
533		# assume the user means: ordered = names(Data)
534	!	ordered <- lav_object_vnames(flat.model, "ov.nox") # new in 0.6-6: changed from ov
535	2x	} else if (is.logical(ordered) && !ordered) {
536	!	ordered <- character(0L)
537	2x	} else if (!is.character(ordered)) {
538	!	lav_msg_stop(gettext("ordered argument must be a character vector"))
539	2x	} else if (length(ordered) == 1L && nchar(ordered) == 0L) {
540	!	ordered <- character(0L)
541		} else {
542		# check if all names in "ordered" occur in the dataset?
543	2x	if (!is.null(data)) {
544	2x	if (inherits(data, "data.frame")) {
545	2x	data_names <- names(data)
546	!	} else if (inherits(data, "matrix")) {
547	!	data_names <- colnames(data)
548		}
549	2x	missing.idx <- which(!ordered %in% data_names)
550	2x	if (length(missing.idx) > 0L) { # FIXme: warn = FALSE has no eff
551	!	lav_msg_warn(gettextf(
552	!	"ordered variable(s): %s could not be found
553	!	in the data and will be ignored",
554	!	paste(ordered[missing.idx], collapse = " ")))
555		}
556		}
557		}
558		}
559
560		# add the variable names that were treated as ordinal
561		# in the model syntax
562	140x	ordered <- unique(c(ordered, lav_object_vnames(flat.model, "ov.ord")))
563
564	140x	ordered
565		}

1		# build def function from partable
2		lav_partable_constraints_def <- function(partable, con = NULL, debug = FALSE,
3		txtOnly = FALSE, warn = TRUE) {
4	239x	if (!missing(debug)) {
5	144x	current.debug <- lav_debug()
6	144x	if (lav_debug(debug))
7	!	on.exit(lav_debug(current.debug), TRUE)
8		}
9		# empty function
10	239x	def.function <- function() NULL
11
12		# if 'con', merge partable + con
13	239x	if (!is.null(con)) {
14	!	partable$lhs <- c(partable$lhs, con$lhs)
15	!	partable$op <- c(partable$op, con$op)
16	!	partable$rhs <- c(partable$rhs, con$rhs)
17		}
18
19		# get := definitions
20	239x	def.idx <- which(partable$op == ":=")
21
22		# catch empty def
23	239x	if (length(def.idx) == 0L) {
24	237x	if (txtOnly) {
25	95x	return(character(0L))
26		} else {
27	142x	return(def.function)
28		}
29		}
30
31		# sort order of def.idx by dependencies
32	2x	deps <- lapply(partable$rhs[def.idx], FUN = function(x) {
33	2x	all.vars(parse(text=x)) })
34	2x	lab.unsorted <- partable$lhs[def.idx]
35	2x	adj.mat <- matrix(0L, nrow = length(def.idx), ncol = length(def.idx))
36	2x	for (i in seq_along(lab.unsorted)) {
37	2x	adj.mat[lab.unsorted %in% deps[[i]], i] <- 1L
38		}
39	2x	def.idx <- def.idx[lav_graph_order_adj_mat(adj.mat, warn = warn)]
40
41		# create function
42	2x	formals(def.function) <- alist(.x. = , ... = )
43	2x	if (txtOnly) {
44	!	BODY.txt <- ""
45		} else {
46	2x	BODY.txt <- paste("{\n# parameter definitions\n\n")
47		}
48
49	2x	lhs.names <- partable$lhs[def.idx]
50	2x	def.labels <- all.vars(parse(file = "", text = partable$rhs[def.idx]))
51		# remove the ones in lhs.names
52	2x	idx <- which(def.labels %in% lhs.names)
53	!	if (length(idx) > 0L) def.labels <- def.labels[-idx]
54
55		# get corresponding 'x' indices
56	2x	def.x.idx <- partable$free[match(def.labels, partable$label)]
57	2x	if (any(is.na(def.x.idx))) {
58	!	lav_msg_stop(gettext(
59	!	"unknown label(s) in variable definition(s):"),
60	!	lav_msg_view(def.labels[which(is.na(def.x.idx))], "none")
61		)
62		}
63	2x	if (any(def.x.idx == 0)) {
64	!	lav_msg_stop(gettext(
65	!	"non-free parameter(s) in variable definition(s):"),
66	!	lav_msg_view(def.labels[which(def.x.idx == 0)], "none")
67		)
68		}
69	2x	def.x.lab <- paste(".x.[", def.x.idx, "]", sep = "")
70		# put both the labels the function BODY
71	2x	if (length(def.x.idx) > 0L) {
72	2x	BODY.txt <- paste(BODY.txt, "# parameter labels\n",
73	2x	paste(def.labels, " <- ", def.x.lab, collapse = "\n"),
74	2x	"\n",
75	2x	sep = ""
76		)
77		}
78
79		# write the definitions literally
80	2x	BODY.txt <- paste(BODY.txt, "\n# parameter definitions\n", sep = "")
81	2x	for (i in 1:length(def.idx)) {
82	2x	BODY.txt <- paste(BODY.txt,
83	2x	lhs.names[i], " <- ", partable$rhs[def.idx[i]], "\n",
84	2x	sep = ""
85		)
86		}
87
88	2x	if (txtOnly) {
89	!	return(BODY.txt)
90		}
91
92		# put the results in 'out'
93	2x	BODY.txt <- paste(BODY.txt, "\nout <- ",
94	2x	paste("c(", paste(lhs.names, collapse = ","), ")\n", sep = ""),
95	2x	sep = ""
96		)
97		# what to do with NA values? -> return +Inf???
98	2x	BODY.txt <- paste(BODY.txt, "out[is.na(out)] <- Inf\n", sep = "")
99	2x	BODY.txt <- paste(BODY.txt, "names(out) <- ",
100	2x	paste("c(\"", paste(lhs.names, collapse = "\",\""), "\")\n", sep = ""),
101	2x	sep = ""
102		)
103	2x	BODY.txt <- paste(BODY.txt, "return(out)\n}\n", sep = "")
104
105	2x	body(def.function) <- parse(file = "", text = BODY.txt)
106	2x	if (lav_debug()) {
107	!	cat("def.function = \n")
108	!	print(def.function)
109	!	cat("\n")
110		}
111
112	2x	def.function
113		}
114
115		# build ceq function from partable
116		# non-trivial equality constraints (linear or nonlinear)
117		# convert to 'ceq(x)' function where 'x' is the (free) parameter vector
118		# and ceq(x) returns the evaluated equality constraints
119		#
120		# eg. if b1 + b2 == 2 (and b1 correspond to, say, x[10] and x[17])
121		# ceq <- function(x) {
122		# out <- rep(NA, 1)
123		# b1 = x[10]; b2 = x[17]
124		# out[1] <- b1 + b2 - 2
125		# }
126		lav_partable_constraints_ceq <- function(partable, con = NULL, debug = FALSE,
127		txtOnly = FALSE) {
128	144x	if (!missing(debug)) {
129	144x	current.debug <- lav_debug()
130	144x	if (lav_debug(debug))
131	!	on.exit(lav_debug(current.debug), TRUE)
132		}
133		# empty function
134	144x	ceq.function <- function() NULL
135
136		# if 'con', merge partable + con
137	144x	if (!is.null(con)) {
138	!	partable$lhs <- c(partable$lhs, con$lhs)
139	!	partable$op <- c(partable$op, con$op)
140	!	partable$rhs <- c(partable$rhs, con$rhs)
141		}
142
143		# get equality constraints
144	144x	eq.idx <- which(partable$op == "==")
145
146		# catch empty ceq
147	144x	if (length(eq.idx) == 0L) {
148	134x	if (txtOnly) {
149	!	return(character(0L))
150		} else {
151	134x	return(ceq.function)
152		}
153		}
154
155		# create function
156	10x	formals(ceq.function) <- alist(.x. = , ... = )
157	10x	if (txtOnly) {
158	!	BODY.txt <- ""
159		} else {
160	10x	BODY.txt <- paste("{\nout <- rep(NA, ", length(eq.idx), ")\n", sep = "")
161		}
162
163		# first come the variable definitions
164	10x	DEF.txt <- lav_partable_constraints_def(partable, txtOnly = TRUE,
165	10x	warn = FALSE)
166	10x	def.idx <- which(partable$op == ":=")
167	10x	BODY.txt <- paste(BODY.txt, DEF.txt, "\n", sep = "")
168
169
170		# extract labels
171	10x	lhs.labels <- all.vars(parse(file = "", text = partable$lhs[eq.idx]))
172	10x	rhs.labels <- all.vars(parse(file = "", text = partable$rhs[eq.idx]))
173	10x	eq.labels <- unique(c(lhs.labels, rhs.labels))
174		# remove def.names from eq.labels
175	10x	if (length(def.idx) > 0L) {
176	!	def.names <- as.character(partable$lhs[def.idx])
177	!	d.idx <- which(eq.labels %in% def.names)
178	!	if (length(d.idx) > 0) eq.labels <- eq.labels[-d.idx]
179		}
180	10x	eq.x.idx <- rep(as.integer(NA), length(eq.labels))
181		# get user-labels ids
182	10x	ulab.idx <- which(eq.labels %in% partable$label)
183	10x	if (length(ulab.idx) > 0L) {
184	!	eq.x.idx[ulab.idx] <- partable$free[match(
185	!	eq.labels[ulab.idx],
186	!	partable$label
187		)]
188		}
189		# get plabels ids
190	10x	plab.idx <- which(eq.labels %in% partable$plabel)
191	10x	if (length(plab.idx) > 0L) {
192	10x	eq.x.idx[plab.idx] <- partable$free[match(
193	10x	eq.labels[plab.idx],
194	10x	partable$plabel
195		)]
196		}
197
198		# check if we have found the label
199	10x	if (any(is.na(eq.x.idx))) {
200	!	lav_msg_stop(gettext("unknown label(s) in equality constraint(s):"),
201	!	lav_msg_view(eq.labels[which(is.na(eq.x.idx))], "none")
202		)
203		}
204		# check if they are all 'free'
205	10x	if (any(eq.x.idx == 0)) {
206	!	fixed.eq.idx <- which(eq.x.idx == 0)
207		# FIXME: what should we do here? we used to stop with an error
208		# from 0.5.18, we give a warning, and replace the non-free label
209		# with its fixed value in ustart
210		# warning("lavaan WARNING: non-free parameter(s) in equality constraint(s): ",
211		# paste(eq.labels[fixed.eq.idx], collapse=" "))
212
213	!	fixed.lab.lhs <- eq.labels[fixed.eq.idx]
214	!	fixed.lab.rhs <- numeric(length(fixed.lab.lhs))
215
216	!	for (i in 1:length(fixed.lab.lhs)) {
217		# first try label
218	!	idx <- match(fixed.lab.lhs[i], partable$label)
219		# then try plabel
220	!	if (is.na(idx)) {
221	!	idx <- match(fixed.lab.lhs[i], partable$plabel)
222		}
223	!	if (is.na(idx)) {
224		# hm, not found? fill in zero, or NA?
225		} else {
226	!	fixed.lab.rhs[i] <- partable$ustart[idx]
227		}
228		}
229
230	!	BODY.txt <- paste(BODY.txt, "# non-free parameter labels\n",
231	!	paste(fixed.lab.lhs, "<-", fixed.lab.rhs, collapse = "\n"),
232	!	"\n",
233	!	sep = ""
234		)
235
236	!	eq.x.idx <- eq.x.idx[-fixed.eq.idx]
237	!	eq.labels <- eq.labels[-fixed.eq.idx]
238		}
239
240		# put the labels the function BODY
241	10x	eq.x.lab <- paste(".x.[", eq.x.idx, "]", sep = "")
242	10x	if (length(eq.x.idx) > 0L) {
243	10x	BODY.txt <- paste(BODY.txt, "# parameter labels\n",
244	10x	paste(eq.labels, "<-", eq.x.lab, collapse = "\n"),
245	10x	"\n",
246	10x	sep = ""
247		)
248		}
249
250		# write the equality constraints literally
251	10x	BODY.txt <- paste(BODY.txt, "\n# equality constraints\n", sep = "")
252	10x	for (i in 1:length(eq.idx)) {
253	110x	lhs <- partable$lhs[eq.idx[i]]
254	110x	rhs <- partable$rhs[eq.idx[i]]
255	110x	if (rhs == "0") {
256	!	eq.string <- lhs
257		} else {
258	110x	eq.string <- paste(lhs, " - (", rhs, ")", sep = "")
259		}
260	110x	BODY.txt <- paste(BODY.txt, "out[", i, "] <- ", eq.string, "\n", sep = "")
261		}
262
263	10x	if (txtOnly) {
264	!	return(BODY.txt)
265		}
266
267		# put the results in 'out'
268		# BODY.txt <- paste(BODY.txt, "\nout <- ",
269		# paste("c(", paste(lhs.names, collapse=","),")\n", sep=""), sep="")
270
271		# what to do with NA values? -> return +Inf???
272	10x	BODY.txt <- paste(BODY.txt, "\n", "out[is.na(out)] <- Inf\n", sep = "")
273	10x	BODY.txt <- paste(BODY.txt, "return(out)\n}\n", sep = "")
274	10x	body(ceq.function) <- parse(file = "", text = BODY.txt)
275	10x	if (lav_debug()) {
276	!	cat("ceq.function = \n")
277	!	print(ceq.function)
278	!	cat("\n")
279		}
280
281	10x	ceq.function
282		}
283
284
285		# build ciq function from partable
286		# non-trivial inequality constraints (linear or nonlinear)
287		# convert to 'cin(x)' function where 'x' is the (free) parameter vector
288		# and cin(x) returns the evaluated inequality constraints
289		#
290		# eg. if b1 + b2 > 2 (and b1 correspond to, say, x[10] and x[17])
291		# cin <- function(x) {
292		# out <- rep(NA, 1)
293		# b1 = x[10]; b2 = x[17]
294		# out[1] <- b1 + b2 - 2
295		# }
296		#
297		# new in 0.6-19: we also add the lower/upper bounds
298		#
299		# NOTE: very similar, but not identitical to ceq, because we need to take
300		# care of the difference between '<' and '>'
301		lav_partable_constraints_ciq <- function(partable, con = NULL, debug = FALSE,
302		txtOnly = FALSE) {
303	144x	if (!missing(debug)) {
304	144x	current.debug <- lav_debug()
305	144x	if (lav_debug(debug))
306	!	on.exit(lav_debug(current.debug), TRUE)
307		}
308		# empty function
309	144x	cin.function <- function() NULL
310
311		# if 'con', merge partable + con
312	144x	if (!is.null(con)) {
313	!	partable$lhs <- c(partable$lhs, con$lhs)
314	!	partable$op <- c(partable$op, con$op)
315	!	partable$rhs <- c(partable$rhs, con$rhs)
316		}
317
318		# get explicit inequality constraints
319	144x	ineq.idx <- which(partable$op == ">" \| partable$op == "<")
320
321		# get lower/upper bounds
322	144x	upper.idx <- integer(0L)
323	144x	lower.idx <- integer(0L)
324	144x	if (!is.null(partable$upper)) {
325	83x	upper.idx <- which(partable$free > 0L & is.finite(partable$upper))
326		}
327	144x	if (!is.null(partable$lower)) {
328	83x	lower.idx <- which(partable$free > 0L & is.finite(partable$lower))
329		}
330
331		# add them to ineq.idx
332	144x	ineq.only.idx <- ineq.idx
333	144x	ineq.idx <- c(upper.idx, lower.idx, ineq.idx)
334
335		# catch empty ciq
336	144x	if (length(ineq.idx) == 0L) {
337	59x	if (txtOnly) {
338	!	return(character(0L))
339		} else {
340	59x	return(cin.function)
341		}
342		}
343
344		# create function
345	85x	formals(cin.function) <- alist(.x. = , ... = )
346	85x	if (txtOnly) {
347	!	BODY.txt <- ""
348		} else {
349	85x	BODY.txt <- paste("{\nout <- rep(NA, ", length(ineq.idx), ")\n", sep = "")
350		}
351
352		# first come the variable definitions
353	85x	DEF.txt <- lav_partable_constraints_def(partable, txtOnly = TRUE,
354	85x	warn = FALSE)
355	85x	def.idx <- which(partable$op == ":=")
356	85x	BODY.txt <- paste(BODY.txt, DEF.txt, "\n", sep = "")
357
358		# extract labels
359	85x	lhs.labels <- all.vars(parse(file = "", text = partable$lhs[ineq.only.idx]))
360	85x	rhs.labels <- all.vars(parse(file = "", text = partable$rhs[ineq.only.idx]))
361	85x	ineq.labels <- unique(c(lhs.labels, rhs.labels))
362		# remove def.names from ineq.labels
363	85x	if (length(def.idx) > 0L) {
364	!	def.names <- as.character(partable$lhs[def.idx])
365	!	d.idx <- which(ineq.labels %in% def.names)
366	!	if (length(d.idx) > 0) ineq.labels <- ineq.labels[-d.idx]
367		}
368	85x	ineq.x.idx <- rep(as.integer(NA), length(ineq.labels))
369		# get user-labels ids
370	85x	ulab.idx <- which(ineq.labels %in% partable$label)
371	85x	if (length(ulab.idx) > 0L) {
372	2x	ineq.x.idx[ulab.idx] <- partable$free[match(
373	2x	ineq.labels[ulab.idx],
374	2x	partable$label
375		)]
376		}
377		# get plabels ids
378	85x	plab.idx <- which(ineq.labels %in% partable$plabel)
379	85x	if (length(plab.idx) > 0L) {
380	!	ineq.x.idx[plab.idx] <- partable$free[match(
381	!	ineq.labels[plab.idx],
382	!	partable$plabel
383		)]
384		}
385
386		# check if we have found the label
387	85x	if (length(ineq.x.idx) > 0L && any(is.na(ineq.x.idx))) {
388	!	lav_msg_stop(gettext("unknown label(s) in inequality constraint(s):"),
389	!	lav_msg_view(ineq.labels[which(is.na(ineq.x.idx))], "none")
390		)
391		}
392
393		# check if they are all 'free'
394	85x	if (length(ineq.x.idx) > 0L && any(ineq.x.idx == 0)) {
395	!	fixed.ineq.idx <- which(ineq.x.idx == 0)
396		# FIXME: what should we do here? we used to stop with an error
397		# from 0.5.18, we give a warning, and replace the non-free label
398		# with its fixed value in ustart
399	!	lav_msg_warn(gettext("non-free parameter(s) in inequality constraint(s):"),
400	!	lav_msg_view(ineq.labels[fixed.ineq.idx],"none")
401		)
402
403	!	fixed.lab.lhs <- ineq.labels[fixed.ineq.idx]
404	!	fixed.lab.rhs <- partable$ustart[match(fixed.lab.lhs, partable$label)]
405	!	BODY.txt <- paste(BODY.txt, "# non-free parameter labels\n",
406	!	paste(fixed.lab.lhs, "<-", fixed.lab.rhs, collapse = "\n"),
407	!	"\n",
408	!	sep = ""
409		)
410
411	!	ineq.x.idx <- ineq.x.idx[-fixed.ineq.idx]
412	!	ineq.labels <- ineq.labels[-fixed.ineq.idx]
413		}
414
415		# put the labels the function BODY
416	85x	if (length(ineq.x.idx) > 0L) {
417	2x	ineq.x.lab <- paste(".x.[", ineq.x.idx, "]", sep = "")
418	2x	if (length(ineq.x.idx) > 0L) {
419	2x	BODY.txt <- paste(BODY.txt, "# parameter labels\n",
420	2x	paste(ineq.labels, "<-", ineq.x.lab, collapse = "\n"),
421	2x	"\n",
422	2x	sep = ""
423		)
424		}
425		}
426
427		# write the constraints literally
428	85x	BODY.txt <- paste(BODY.txt, "\n# inequality constraints\n", sep = "")
429	85x	FREE <- partable$free
430	85x	FREE[FREE > 0] <- seq_len(length(FREE[FREE > 0]))
431	85x	for (i in 1:length(ineq.idx)) {
432	525x	lhs <- partable$lhs[ineq.idx[i]]
433	525x	op <- partable$op[ineq.idx[i]]
434	525x	rhs <- partable$rhs[ineq.idx[i]]
435
436	525x	if (ineq.idx[i] %in% ineq.only.idx) {
437		# EXPLICIT inequality constraints
438		# note,this is different from ==, because we have < AND >
439	4x	if (rhs == "0" && op == ">") {
440	!	ineq.string <- lhs
441	4x	} else if (rhs == "0" && op == "<") {
442	!	ineq.string <- paste(rhs, " - (", lhs, ")", sep = "")
443	4x	} else if (rhs != "0" && op == ">") {
444	!	ineq.string <- paste(lhs, " - (", rhs, ")", sep = "")
445	4x	} else if (rhs != "0" && op == "<") {
446	4x	ineq.string <- paste(rhs, " - (", lhs, ")", sep = "")
447		}
448	521x	} else if (ineq.idx[i] %in% upper.idx) {
449		# simple upper bound
450	!	val <- partable$upper[ineq.idx[i]]
451	!	xlab <- paste(".x.[", FREE[ineq.idx[i]], "]", sep = "")
452	!	ineq.string <- paste(val, " - (", xlab, ")", sep = "")
453	521x	} else if (ineq.idx[i] %in% lower.idx) {
454		# simple lower bound
455	521x	val <- partable$lower[ineq.idx[i]]
456	521x	xlab <- paste(".x.[", FREE[ineq.idx[i]], "]", sep = "")
457	521x	ineq.string <- paste(xlab, " - (", val, ")", sep = "")
458		}
459
460	525x	BODY.txt <- paste(BODY.txt, "out[", i, "] <- ", ineq.string, "\n", sep = "")
461		}
462
463	85x	if (txtOnly) {
464	!	return(BODY.txt)
465		}
466
467		# put the results in 'out'
468	85x	BODY.txt <- paste(BODY.txt, "\n", "out[is.na(out)] <- Inf\n", sep = "")
469	85x	if (length(upper.idx) > 0L \|\| length(lower.idx) > 0L) {
470	83x	bound.idx <- which(ineq.idx %in% c(upper.idx, lower.idx))
471	83x	bound.txt <- paste("c(", paste(bound.idx, collapse = ", "), ")", sep = "")
472	83x	BODY.txt <- paste(BODY.txt, "attr(out, \"bound.idx\") <- ", bound.txt,
473	83x	"\n", sep = "")
474		}
475	85x	BODY.txt <- paste(BODY.txt, "return(out)\n}\n", sep = "")
476	85x	body(cin.function) <- parse(file = "", text = BODY.txt)
477	85x	if (lav_debug()) {
478	!	cat("cin.function = \n")
479	!	print(cin.function)
480	!	cat("\n")
481		}
482
483	85x	cin.function
484		}
485
486		# return a named vector of the 'free' indices, for the labels that
487		# are used in a constrained (or optionally a definition)
488		# (always 0 for definitions)
489		lav_partable_constraints_label_id <- function(partable, con = NULL,
490		def = TRUE) {
491		# if 'con', merge partable + con
492	10x	if (!is.null(con)) {
493	!	partable$lhs <- c(partable$lhs, con$lhs)
494	!	partable$op <- c(partable$op, con$op)
495	!	partable$rhs <- c(partable$rhs, con$rhs)
496		}
497
498		# get constraints
499	10x	if (def) {
500	10x	con.idx <- which(partable$op %in% c("==", "<", ">", ":="))
501		} else {
502	!	con.idx <- which(partable$op %in% c("==", "<", ">"))
503		}
504
505		# catch empty con
506	10x	if (length(con.idx) == 0L) {
507	!	return(integer(0L))
508		}
509
510	10x	def.idx <- which(partable$op == ":=")
511
512		# extract labels
513	10x	lhs.labels <- all.vars(parse(file = "", text = partable$lhs[con.idx]))
514	10x	rhs.labels <- all.vars(parse(file = "", text = partable$rhs[con.idx]))
515	10x	con.labels <- unique(c(lhs.labels, rhs.labels))
516
517		# remove def.names from con.labels (unless def = TRUE)
518	10x	if (!def && length(def.idx) > 0L) {
519	!	def.names <- as.character(partable$lhs[def.idx])
520	!	d.idx <- which(con.labels %in% def.names)
521	!	if (length(d.idx) > 0) {
522	!	con.labels <- con.labels[-d.idx]
523		}
524		}
525	10x	con.x.idx <- rep(as.integer(NA), length(con.labels))
526
527		# get user-labels ids
528	10x	ulab.idx <- which(con.labels %in% partable$label)
529	10x	if (length(ulab.idx) > 0L) {
530	!	con.x.idx[ulab.idx] <- partable$free[match(
531	!	con.labels[ulab.idx],
532	!	partable$label
533		)]
534		}
535		# get plabels ids
536	10x	plab.idx <- which(con.labels %in% partable$plabel)
537	10x	if (length(plab.idx) > 0L) {
538	10x	con.x.idx[plab.idx] <- partable$free[match(
539	10x	con.labels[plab.idx],
540	10x	partable$plabel
541		)]
542		}
543
544		# check if we have found the label
545	10x	if (any(is.na(con.x.idx))) {
546	!	lav_msg_warn(gettext("unknown label(s) in equality constraint(s):"),
547	!	lav_msg_view(con.labels[which(is.na(con.x.idx))], "none")
548		)
549		}
550
551		# return named integer vector
552	10x	names(con.x.idx) <- con.labels
553
554	10x	con.x.idx
555		}
556

1		lav_points_beziers <- function(x,
2		y = NULL,
3		col = par("col"),
4		lwd = par("lwd")
5		) {
6	!	if (is.null(y)) {
7	!	if (dim(x)[1L] == 2) {
8	!	p_x <- x[1L, ]
9	!	p_y <- x[2L, ]
10		} else {
11	!	p_x <- x[, 1L]
12	!	p_y <- x[, 2L]
13		}
14		} else {
15	!	p_x <- x
16	!	p_y <- y
17		}
18	!	stopifnot(length(p_x) == length(p_y))
19	!	t <- seq(0, 1, length.out = 50)
20	!	if (length(p_x) == 3L) {
21	!	punten_x <- (1 - t)^2 * p_x[1] + 2 * (1 - t) * t * p_x[2] + t^2 * p_x[3]
22	!	punten_y <- (1 - t)^2 * p_y[1] + 2 * (1 - t) * t * p_y[2] + t^2 * p_y[3]
23		} else {
24	!	punten_x <- (1 - t)^3 * p_x[1] + 3 * t * (1 - t)^2 * p_x[2] +
25	!	3 * t^2 * (1 - t) * p_x[3] + t^3 * p_x[4]
26	!	punten_y <- (1 - t)^3 * p_y[1] + 3 * t * (1 - t)^2 * p_y[2] +
27	!	3 * t^2 * (1 - t) * p_y[3] + t^3 * p_y[4]
28		}
29	!	lines(punten_x, punten_y, col = col, lwd = lwd)
30		}
31
32		lav_plotinfo_rgraph <- function(plotinfo,
33		sloped.labels = TRUE,
34		outfile = "",
35		addgrid = TRUE,
36		mlovcolors = c("lightgreen", "lightblue"),
37		lightness = 1,
38		italic = TRUE,
39		auto.subscript = TRUE) {
40	!	font <- ifelse(italic, 3L, 1L)
41	!	node_elements <- function(nodetiepe, noderadius) {
42		# define form, color and anchors for a node type
43	!	thetas <- switch(nodetiepe,
44	!	lv = ,
45	!	varlv = seq(0, 2 * pi, length.out = 50L),
46	!	ov = seq(pi / 4, 2 * pi, by = pi / 2),
47	!	wov = ,
48	!	bov = c(
49	!	seq(pi / 4 - pi / 10, pi / 4 + pi / 10, by = pi / 60),
50	!	seq(3 * pi / 4 - pi / 10, 3 * pi / 4 + pi / 10, by = pi / 60),
51	!	seq(5 * pi / 4 - pi / 10, 5 * pi / 4 + pi / 10, by = pi / 60),
52	!	seq(7 * pi / 4 - pi / 10, 7 * pi / 4 + pi / 10, by = pi / 60)
53		),
54	!	cv = seq(0, 2 * pi, by = pi / 3),
55	!	const = seq(pi / 2, 2 * pi, by = 2 * pi / 3)
56		)
57	!	localradius <- noderadius
58	!	if (nodetiepe == "varlv") localradius <- noderadius * .8
59	!	drawx <- localradius * cos(thetas)
60	!	drawy <- localradius * sin(thetas)
61	!	wovbovflat <- max(drawx)
62	!	boxcol <- switch(nodetiepe,
63	!	lv = NA_integer_,
64	!	varlv = NA_integer_,
65	!	ov = NA_integer_,
66	!	wov = mlovcolors[1L],
67	!	bov = mlovcolors[2L],
68	!	cv = NA_integer_,
69	!	const = NA_integer_
70		)
71	!	n <- c(0, switch(nodetiepe,
72	!	lv = ,
73	!	varlv = ,
74	!	const = localradius,
75	!	ov = localradius * sqrt(2) / 2,
76	!	wov = ,
77	!	bov = wovbovflat,
78	!	cv = localradius * sqrt(3) / 2
79		))
80	!	s <- c(0, switch(nodetiepe,
81	!	lv = ,
82	!	varlv = -localradius,
83	!	ov = -localradius * sqrt(2) / 2,
84	!	wov = ,
85	!	bov = -wovbovflat,
86	!	cv = -localradius * sqrt(3) / 2,
87	!	const = -localradius * 0.5
88		))
89	!	e <- switch(nodetiepe,
90	!	lv = ,
91	!	varlv = ,
92	!	cv = c(localradius, 0),
93	!	ov = c(localradius * sqrt(2) / 2, 0),
94	!	wov = ,
95	!	bov = c(wovbovflat, 0),
96	!	const = c(localradius * sqrt(3) / 2, -localradius * 0.5)
97		)
98	!	w <- c(-e[1L], e[2L])
99	!	ne <- switch(nodetiepe,
100	!	lv = ,
101	!	varlv = ,
102	!	ov = ,
103	!	wov = ,
104	!	bov = localradius * sqrt(0.5) * c(1, 1),
105	!	cv = localradius * c(0.5, sqrt(3) / 2),
106	!	const = e
107		)
108	!	nw <- c(-ne[1L], ne[2L])
109	!	se <- switch(nodetiepe,
110	!	lv = ,
111	!	varlv = ,
112	!	ov = ,
113	!	wov = ,
114	!	bov = localradius * sqrt(0.5) * c(1, -1),
115	!	cv = localradius * c(0.5, -sqrt(3) / 2),
116	!	const = e
117		)
118	!	sw <- c(-se[1L], se[2L])
119	!	list(
120	!	drawx = drawx, drawy = drawy, boxcol = boxcol, n = n, ne = ne, e = e,
121	!	se = se, s = s, sw = sw, w = w, nw = nw
122		)
123		}
124
125	!	vecrotate <- function(vec, angle) {
126	!	c(
127	!	cos(angle) * vec[1] + sin(angle) * vec[2],
128	!	-sin(angle) * vec[1] + cos(angle) * vec[2]
129		)
130		}
131	!	plot_arrow <- function(tip, dirvec) {
132	!	unitvec <- dirvec / sqrt(sum(dirvec^2))
133	!	arrowangle <- pi * 25 / 180
134	!	arrowinset <- 0.4
135	!	args <- rbind(
136	!	tip,
137	!	tip + vecrotate(-unitvec * arrowlength, arrowangle),
138	!	tip - unitvec * arrowlength * (1 - arrowinset),
139	!	tip + vecrotate(-unitvec * arrowlength, -arrowangle)
140		)
141	!	polygon(args, col = "black", border = NA)
142		}
143	!	plot_edge <- function(van, naar, label = "", dubbel = FALSE,
144	!	control = NA_real_, below = FALSE, txtcex = 0.9) {
145	!	labele <- lav_label_code(label, auto.subscript = auto.subscript)$r
146	!	dirvec <- naar - van
147	!	theta <- atan2(naar[2] - van[2], naar[1] - van[1])
148	!	srt <- ifelse(sloped.labels, 180 * theta / pi, 0)
149	!	if (srt > 90) srt <- srt - 180
150	!	if (srt < -90) srt <- srt + 180
151	!	if (is.na(control[1L])) {
152	!	args <- rbind(van, naar)
153	!	lines(args, lwd = 2)
154	!	plot_arrow(naar, dirvec)
155	!	if (dubbel) plot_arrow(van, -dirvec)
156	!	midden <- (van + naar) * 0.5
157		} else {
158		# gebogen lijn (quadratic lav_points_beziers)
159	!	lav_points_beziers(rbind(van, control, naar), lwd = 2)
160	!	midden <- (van + naar) / 4 + control / 2
161	!	plot_arrow(naar, naar - control)
162	!	if (dubbel) plot_arrow(van, van - control)
163		}
164	!	if (label != "") {
165	!	if (below) {
166	!	if (theta >= 0 && theta < 90) {
167	!	text(midden[1L], midden[2L], labele,
168	!	adj = c(0, 1),
169	!	srt = srt, cex = txtcex, font = font
170		)
171	!	} else if (theta >= 90) {
172	!	text(midden[1L], midden[2L], labele,
173	!	adj = c(1, 1),
174	!	srt = srt, cex = txtcex, font = font
175		)
176	!	} else if (theta < -90) {
177	!	text(midden[1L], midden[2L], labele,
178	!	adj = c(0, 1),
179	!	srt = srt, cex = txtcex, font = font
180		)
181		} else {
182	!	text(midden[1L], midden[2L], labele,
183	!	adj = c(1, 1),
184	!	srt = srt, cex = txtcex, font = font
185		)
186		}
187		} else {
188	!	if (theta >= 0 && theta < 90) {
189	!	text(midden[1L], midden[2L], labele,
190	!	adj = c(1, 0),
191	!	srt = srt, cex = txtcex, font = font
192		)
193	!	} else if (theta >= 90) {
194	!	text(midden[1L], midden[2L], labele,
195	!	adj = c(0, 0),
196	!	srt = srt, cex = txtcex, font = font
197		)
198	!	} else if (theta < -90) {
199	!	text(midden[1L], midden[2L], labele,
200	!	adj = c(1, 0),
201	!	srt = srt, cex = txtcex, font = font
202		)
203		} else {
204	!	text(midden[1L], midden[2L], labele,
205	!	adj = c(0, 0),
206	!	srt = srt, cex = txtcex, font = font
207		)
208		}
209		}
210		}
211		}
212	!	plot_var <- function(waar, noderadius, label = "", side = "n", txtcex = 0.9) {
213	!	labele <- lav_label_code(label, auto.subscript = auto.subscript)$r
214	!	thetarange <- c(pi / 6, 11 * pi / 6)
215	!	if (side == "s") thetarange <- thetarange + pi / 2
216	!	if (side == "e") thetarange <- thetarange + pi
217	!	if (side == "n") thetarange <- thetarange + 3 * pi / 2
218	!	localradius <- noderadius * 0.8
219	!	middelpt <- switch(side,
220	!	n = c(0, localradius),
221	!	w = c(-localradius, 0),
222	!	s = c(0, -localradius),
223	!	e = c(localradius, 0)
224		)
225	!	middelpt <- middelpt + waar
226		# cirkelsegment
227	!	thetas <- seq(thetarange[1L], thetarange[2L], length.out = 40)
228	!	straal <- localradius
229	!	xs <- middelpt[1] + cos(thetas) * straal
230	!	ys <- middelpt[2] + sin(thetas) * straal
231	!	lines(xs, ys)
232		# pijlen
233	!	plot_arrow(c(xs[1], ys[1]), c(sin(thetarange[1]), -cos(thetarange[1])))
234	!	plot_arrow(c(xs[40], ys[40]), c(-sin(thetarange[2]), cos(thetarange[2])))
235		# label
236	!	if (label != "") {
237	!	text(middelpt[1L], middelpt[2L], labele,
238	!	adj = 0.5, cex = txtcex * 0.8,
239	!	font = font
240		)
241		}
242		}
243	!	plot_node <- function(waar, tiepe, label = "", txtcex = 0.9) {
244	!	labele <- lav_label_code(label, auto.subscript = auto.subscript)$r
245	!	elems <- node_elements(tiepe, noderadius)
246	!	x <- waar[1] + elems$drawx
247	!	y <- waar[2] + elems$drawy
248	!	polygon(x, y, col = elems$boxcol, lwd = 1)
249	!	text(waar[1L], waar[2L], labele, adj = 0.5, cex = txtcex, font = font)
250		}
251	!	mlrij <- plotinfo$mlrij
252	!	if (is.null(mlrij)) {
253	!	lav_msg_stop(gettext(
254	!	"plotinfo hasn't been processed by lav_plotinfo_positions!"
255		))
256		}
257	!	nodes <- plotinfo$nodes
258	!	edges <- plotinfo$edges
259	!	noderadius <- 0.3
260	!	arrowlength <- noderadius / 3
261	!	rijen <- max(nodes$rij)
262	!	kolommen <- max(nodes$kolom)
263	!	if (outfile != "") png(outfile, 960, 960, "px")
264	!	opar <- par(mar = c(1L, 1L, 1L, 1L) + 0.1)
265	!	plot.default(
266	!	x = c(0, lightness * kolommen + 1),
267	!	c(0, lightness * rijen + 1), type = "n",
268	!	xlab = "", ylab = "", axes = FALSE, asp = 1
269		)
270	!	if (addgrid) {
271	!	abline(
272	!	v = seq.int(kolommen) * lightness,
273	!	h = seq.int(rijen) * lightness,
274	!	lwd = 1,
275	!	lty = "dotted", col = "lightgray"
276		)
277	!	text(seq.int(kolommen) * lightness, 0.3,
278	!	labels = seq.int(kolommen), adj = 1, cex = 0.7
279		)
280	!	text(0.3, seq.int(rijen) * lightness,
281	!	labels = seq.int(rijen, 1), adj = 1, cex = 0.7
282		)
283		}
284	!	if (mlrij > 0L) abline(h = rijen - mlrij + 1, lwd = 2)
285	!	for (j in seq.int(nrow(edges))) {
286	!	if (edges$naar[j] != edges$van[j]) {
287	!	van <- which(nodes$id == edges$van[j])
288	!	naar <- which(nodes$id == edges$naar[j])
289	!	adrvan <- lightness *
290	!	c(nodes$kolom[van], rijen - nodes$rij[van] + 1)
291	!	elems <- node_elements(nodes$tiepe[van], noderadius)
292	!	adrvan <- adrvan + elems[[edges$vananker[j]]]
293	!	adrnaar <- lightness *
294	!	c(nodes$kolom[naar], rijen - nodes$rij[naar] + 1)
295	!	elems <- node_elements(nodes$tiepe[naar], noderadius)
296	!	adrnaar <- adrnaar + elems[[edges$naaranker[j]]]
297	!	if (is.na(edges$controlpt.rij[j])) {
298	!	plot_edge(adrvan, adrnaar, edges$label[j],
299	!	dubbel = (edges$tiepe[j] == "~~"),
300	!	below = edges$labelbelow[j]
301		)
302		} else {
303	!	controlpt <- lightness * c(
304	!	edges$controlpt.kol[j],
305	!	rijen - edges$controlpt.rij[j] + 1
306		)
307	!	plot_edge(adrvan, adrnaar, edges$label[j],
308	!	dubbel = (edges$tiepe[j] == "~~"),
309	!	below = edges$labelbelow[j],
310	!	control = controlpt
311		)
312		}
313		} else {
314	!	van <- which(nodes$id == edges$van[j])
315	!	adrvan <- lightness * c(nodes$kolom[van], rijen - nodes$rij[van] + 1)
316	!	elems <- node_elements(nodes$tiepe[van], noderadius)
317	!	adrvan <- adrvan + elems[[edges$vananker[j]]]
318	!	plot_var(adrvan, noderadius, edges$label[j], edges$vananker[j])
319		}
320		}
321	!	for (j in seq.int(nrow(nodes))) {
322	!	plot_node(
323	!	lightness *
324	!	c(nodes$kolom[j], rijen - nodes$rij[j] + 1),
325	!	nodes$tiepe[j],
326	!	nodes$naam[j]
327		)
328		}
329	!	par(opar)
330	!	if (outfile != "") dev.off()
331	!	invisible(NULL)
332		}

1		# rotation algorithms for multiple groups
2		#
3		# YR 22 Dec 2025 -- initial version
4		#
5		# - rstarts only affects the 'initial' rotation
6
7		# main function to rotate a list of matrices 'Alist'
8		lav_matrix_rotate_mg <- function(Alist = NULL, # original matrices
9		orthogonal = FALSE, # default is oblique
10		method = "geomin", # default rot method
11		method.args = list(
12		geomin.epsilon = 0.01,
13		orthomax.gamma = 1,
14		cf.gamma = 0,
15		oblimin.gamma = 0,
16		promax.kappa = 4,
17		target = matrix(0, 0, 0),
18		target.mask = matrix(0, 0, 0)
19		),
20		init.rotList = NULL, # initial rotation matrix
21		init.ROT.check = TRUE, # check if init ROT is ok
22		rstarts = 30L, # number of random starts
23		# row.weights = "default", # row weighting
24		# std.ov = FALSE, # rescale ov
25		# ov.var = NULL, # ov variances
26		# algorithm = "gpa", # rotation algorithm
27		mg.algorithm = "pairwise",
28		mg.agreement.method = "procrustes",
29		mg.agreement.weight = 0.5,
30		reflect = TRUE, # refect sign
31		order.lv.by = "index", # how to order the lv's
32		# gpa.tol = 0.00001, # stopping tol gpa
33		tol = 1e-07, # stopping tol others
34		keep.rep = FALSE, # store replications
35		max.iter = 10000L) { # max iterations
36
37		# check Alist
38	!	if (!is.list(Alist)) {
39	!	lav_msg_stop(gettext("Alist does not seem to be a list"))
40		}
41	!	ngroups <- length(Alist)
42
43		# check A
44	!	A <- Alist[[1]]
45	!	if (!inherits(A, "matrix")) {
46	!	lav_msg_stop(gettext("A does not seem to be a matrix"))
47		}
48
49	!	P <- nrow(A)
50	!	M <- ncol(A)
51	!	if (M < 2L) { # single dimension
52	!	res <- list(
53	!	lambdaList = Alist, rotList = NULL,
54	!	orthogonal = orthogonal, method = "none",
55	!	method.args = list(), row.weights = "none",
56	!	algorithm = "none", iter = 0L, converged = TRUE,
57	!	method.value = 0
58		)
59	!	return(res)
60		}
61
62		# method
63	!	method <- tolower(method)
64
65		# no promax (for now)
66	!	if (method == "promax") {
67	!	lav_msg_stop(gettext("mg-promax + agreement not supported"))
68		}
69
70		# check init.ROT per group
71	!	if (!is.null(init.rotList) && init.ROT.check) {
72	!	for(g in seq_len(ngroups)) {
73	!	init.ROT <- init.rotList[[g]]
74	!	if (!inherits(init.ROT, "matrix")) {
75	!	lav_msg_stop(gettext("init.ROT does not seem to a matrix"))
76		}
77	!	if (nrow(init.ROT) != M) {
78	!	lav_msg_stop(gettextf(
79	!	"nrow(init.ROT) = %1$s does not equal ncol(A) = %2$s",
80	!	nrow(init.ROT), M
81		))
82		}
83	!	if (nrow(init.ROT) != ncol(init.ROT)) {
84	!	lav_msg_stop(gettextf(
85	!	"nrow(init.ROT) = %1$s does not equal ncol(init.ROT) = %2$s",
86	!	nrow(init.ROT), ncol(init.ROT)
87		))
88		}
89		# rotation matrix?
90	!	if (!lav_matrix_rotate_check(init.ROT, orthogonal = orthogonal)) {
91	!	lav_msg_stop(gettext("init.ROT does not look like a rotation matrix"))
92		}
93		} # group
94		} # check init.rotList
95
96		# determine method function name
97	!	if (method %in% c(
98	!	"cf-quartimax", "cf-varimax", "cf-equamax",
99	!	"cf-parsimax", "cf-facparsim"
100		)) {
101	!	method.fname <- "lav_matrix_rotate_cf"
102	!	method.args$cf.gamma <- switch(method,
103	!	"cf-quartimax" = 0,
104	!	"cf-varimax" = 1 / P,
105	!	"cf-equamax" = M / (2 * P),
106	!	"cf-parsimax" = (M - 1) / (P + M - 2),
107	!	"cf-facparsim" = 1
108		)
109	!	} else if (method %in% c("bi-quartimin", "biquartimin")) {
110	!	method.fname <- "lav_matrix_rotate_biquartimin"
111	!	} else if (method %in% c("bi-geomin", "bigeomin")) {
112	!	method.fname <- "lav_matrix_rotate_bigeomin"
113	!	} else if (method == "target.strict") {
114	!	method.fname <- "lav_matrix_rotate_target"
115		} else {
116	!	method.fname <- paste("lav_matrix_rotate_", method, sep = "")
117		}
118
119		# check if rotation method exists
120	!	check <- try(get(method.fname), silent = TRUE)
121	!	if (inherits(check, "try-error")) {
122	!	lav_msg_stop(gettext("unknown rotation method:"), method.fname)
123		}
124
125		# if target, check target matrix
126	!	if (method == "target.strict" \|\| method == "pst") {
127	!	target <- method.args$target
128	!	if (is.list(target)) {
129	!	method.args$target <- target <- target[[1L]] # always take the first group
130		}
131		# check dimension of target/A
132	!	if (nrow(target) != nrow(A)) {
133	!	lav_msg_stop(gettext("nrow(target) != nrow(A)"))
134		}
135	!	if (ncol(target) != ncol(A)) {
136	!	lav_msg_stop(gettext("ncol(target) != ncol(A)"))
137		}
138		}
139	!	if (method == "pst") {
140	!	target.mask <- method.args$target.mask
141	!	if (is.list(target.mask)) {
142	!	method.args$target.mask <- target.mask <- target.mask[[1L]]
143		}
144		# check dimension of target.mask/A
145	!	if (nrow(target.mask) != nrow(A)) {
146	!	lav_msg_stop(gettext("nrow(target.mask) != nrow(A)"))
147		}
148	!	if (ncol(target.mask) != ncol(A)) {
149	!	lav_msg_stop(gettext("col(target.mask) != ncol(A)"))
150		}
151		}
152		# we keep this here, so lav_matrix_rotate() can be used independently
153	!	if (method == "target.strict" && anyNA(target)) {
154	!	method <- "pst"
155	!	method.fname <- "lav_matrix_rotate_pst"
156	!	target.mask <- matrix(1, nrow = nrow(target), ncol = ncol(target))
157	!	target.mask[is.na(target)] <- 0
158	!	method.args$target.mask <- target.mask
159		}
160
161		# set orthogonal option
162	!	if (missing(orthogonal)) {
163		# the default is oblique, except for varimax, entropy and a few others
164	!	if (method %in% c(
165	!	"varimax", "entropy", "mccammon",
166	!	"tandem1", "tandem2"
167		)) {
168	!	orthogonal <- TRUE
169		} else {
170	!	orthogonal <- FALSE
171		}
172		} else {
173	!	if (!orthogonal && method %in% c(
174	!	"varimax", "entropy", "mccammon",
175	!	"tandem1", "tandem2"
176		)) {
177	!	lav_msg_warn(gettextf(
178	!	"rotation method %s may not work with oblique rotation.",
179	!	dQuote(method)
180		))
181		}
182		}
183
184		# 0. initialize: rotate each group separately + reorder
185	!	Alist.orig <- Alist
186	!	orderList <- vector("list", length = ngroups)
187	!	for (g in seq_len(ngroups)) {
188	!	if (lav_verbose()) {
189	!	cat(" group = ", g, "\n")
190		}
191	!	res0 <- lav_matrix_rotate(
192	!	A = Alist[[g]],
193	!	orthogonal = orthogonal,
194	!	method = method,
195	!	method.args = method.args,
196	!	init.ROT = NULL,
197	!	init.ROT.check = FALSE,
198	!	rstarts = rstarts,
199	!	row.weights = "none",
200	!	std.ov = FALSE,
201	!	ov.var = NULL,
202	!	algorithm = "pairwise",
203	!	reflect = reflect,
204	!	order.lv.by = order.lv.by,
205	!	tol = tol,
206	!	max.iter = max.iter,
207	!	group = g
208		)
209	!	if (g > 1L) {
210		# reorder factors to align with the first group
211	!	order.idx <- lav_efa_find_best_order(
212	!	lambda_ref = Alist[[1]],
213	!	lambda_target = res0$LAMBDA
214		)
215	!	Alist[[g]] <- res0$LAMBDA[, order.idx, drop = FALSE]
216	!	orderList[[g]] <- order.idx
217		} else {
218	!	Alist[[g]] <- res0$LAMBDA
219	!	orderList[[g]] <- res0$order.idx
220		}
221		} # group
222
223		# # set row.weights
224		# row.weights <- tolower(row.weights)
225		# if (row.weights == "default") {
226		# # the default is "none", except for varimax
227		# if (method %in% c("varimax", "promax")) {
228		# row.weights <- "kaiser"
229		# } else {
230		# row.weights <- "none"
231		# }
232		# }
233
234		# # check algorithm
235		# algorithm <- tolower(algorithm)
236		# if (algorithm %in% c("gpa", "pairwise", "none")) {
237		# # nothing to do
238		# } else {
239		# lav_msg_stop(gettext("algorithm must be gpa or pairwise"))
240		# }
241
242		# 1. compute row weigths
243
244		# # 1.a cov -> cor?
245		# if (std.ov) {
246		# A <- A * 1 / sqrt(ov.var)
247		# }
248		#
249		# if (row.weights == "none") {
250		# weights <- rep(1.0, P)
251		# } else if (row.weights == "kaiser") {
252		# weights <- lav_matrix_rotate_kaiser_weights(A)
253		# } else if (row.weights == "cureton-mulaik") {
254		# weights <- lav_matrix_rotate_cm_weights(A)
255		# } else {
256		# lav_msg_stop(gettext("row.weights can be none, kaiser or cureton-mulaik"))
257		# }
258		# A <- A * weights
259
260
261		# 2. rotate
262
263		# multiple random starts?
264		# if (rstarts > 0L) {
265		# REP <- lapply(seq_len(rstarts), function(rep) {
266		# # random start (always orthogonal)
267		# # init.ROT <- lav_matrix_rotate_gen(M = M, orthogonal = TRUE)
268		# # init.ROT <- lav_matrix_rotate_gen(M = M, orthogonal = orthogonal)
269		#
270		# if (lav_verbose()) {
271		# cat("\n")
272		# cat("rstart = ", sprintf("%4d", rep), " start:\n")
273		# }
274		#
275		# # mg-pairwise + agreement
276		# rotList <- lav_matrix_rotate_pairwise_mg(
277		# Alist = Alist,
278		# orthogonal = orthogonal,
279		# random.ROT = TRUE,
280		# method.fname = method.fname,
281		# method.args = method.args,
282		# tol = tol,
283		# max.iter = max.iter
284		# )
285		# info <- attr(rotList, "info")
286		# attr(rotList, "info") <- NULL
287		# res <- list(value = info$method.value, rotList = rotList)
288		#
289		# if (lav_verbose()) {
290		# cat(
291		# "rstart = ", sprintf("%4d", rep),
292		# " end; current crit = ", sprintf("%17.15f", res$value), "\n"
293		# )
294		# }
295		# res
296		# })
297		# best.idx <- which.min(sapply(REP, "[[", "value"))
298		# rotList <- REP[[best.idx]]$rotList
299		# if (keep.rep) {
300		# info <- list(method.value = REP[[best.idx]]$value, REP = REP)
301		# } else {
302		# info <- list(method.value = REP[[best.idx]]$value)
303		# }
304		# } else { # just a single rstart
305		# initial rotation matrix
306		# if (is.null(init.ROT)) {
307		# init.ROT <- diag(M)
308		# }
309
310	!	if (lav_verbose()) {
311	!	cat(" mg-pairwise + agreement rotation:\n")
312		}
313	!	rotList <- lav_matrix_rotate_pairwise_mg(
314	!	Alist = Alist,
315	!	orthogonal = orthogonal,
316	!	random.ROT = FALSE,
317	!	method.fname = method.fname,
318	!	method.args = method.args,
319	!	mg.agreement.method = mg.agreement.method,
320	!	mg.agreement.weight = mg.agreement.weight,
321	!	tol = tol,
322	!	max.iter = max.iter
323		)
324	!	info <- attr(rotList, "info")
325	!	attr(rotList, "info") <- NULL
326		#}
327	!	lambdaList <- vector("list", length = ngroups)
328	!	for (g in seq_len(ngroups)) {
329	!	A <- Alist[[g]]
330	!	ROT <- rotList[[g]]
331
332	!	if (orthogonal) {
333		# LAMBDA <- A %*% solve(t(ROT))
334		# note: when ROT is orthogonal, solve(t(ROT)) == ROT
335	!	LAMBDA <- A %*% ROT
336		} else {
337		# LAMBDA <- A %*% solve(t(ROT))
338	!	LAMBDA <- t(solve(ROT, t(A)))
339		}
340
341		# # 3. undo row weighting
342		# LAMBDA <- LAMBDA / weights
343
344		# # 3.b undo cov -> cor
345		# if (std.ov) {
346		# LAMBDA <- LAMBDA * sqrt(ov.var)
347		# }
348
349		# put back in List
350	!	lambdaList[[g]] <- LAMBDA
351		} # group
352
353		# re-compute final rotation matrix, using Alist.orig
354		# because in step 0, we already rotated (per group)
355	!	rotList <- vector("list", length = ngroups)
356	!	if (orthogonal) {
357	!	for (g in seq_len(ngroups)) {
358	!	rotList[[g]] <- solve(
359	!	crossprod(Alist.orig[[g]]),
360	!	crossprod(Alist.orig[[g]], lambdaList[[g]])
361		)
362		}
363		} else {
364	!	for (g in seq_len(ngroups)) {
365		# to be compatible with GPa
366	!	ROTt.inv <- solve(
367	!	crossprod(Alist.orig[[g]]),
368	!	crossprod(Alist.orig[[g]], lambdaList[[g]])
369		)
370	!	rotList[[g]] <- solve(t(ROTt.inv))
371		}
372		}
373
374		# 6. return results as a list
375	!	res <- list(
376	!	lambdaList = lambdaList, rotList = rotList,
377	!	orderList = orderList,
378	!	orthogonal = orthogonal, method = method,
379	!	method.args = method.args, row.weights = "none"
380		)
381
382		# add method info
383	!	res <- c(res, info)
384
385	!	res
386		}
387
388
389		# pairwise rotation algorithm with direct line search
390		# (see lav_matrix_rotate_pairwise()
391		#
392		# but adapted to handle multiple groups + an agreement criterion
393		#
394		lav_matrix_rotate_pairwise_mg <- function(Alist = NULL, # original matrices
395		orthogonal = FALSE,
396		random.ROT = FALSE,
397		method.fname = NULL, # crit function
398		method.args = list(), # method args
399		tol = 1e-8,
400		mg.agreement.weight = 0.50,
401		mg.agreement.method = "procrustes",
402		scale = TRUE,
403		max.iter = 1000L) {
404		# first group is 'A'
405	!	A <- Alist[[1]]
406	!	ngroups <- length(Alist)
407
408		# number of columns
409	!	M <- ncol(A)
410
411		# initial LAMBDA + PSI
412	!	lambdaList <- Alist
413	!	psiList <- rep(list(diag(M)), ngroups)
414
415		# random initial rotation?
416	!	if (random.ROT) {
417	!	for (g in seq_len(ngroups)) {
418	!	init.ROT <- lav_matrix_rotate_gen(M = M, orthogonal = TRUE)
419	!	if (orthogonal) {
420	!	lambdaList[[g]] <- Alist[[g]] %*% init.ROT
421		} else {
422	!	lambdaList[[g]] <- t(solve(init.ROT, t(Alist[[g]])))
423	!	psiList[[g]] <- crossprod(init.ROT)
424		}
425		}
426		}
427
428		# using the current LAMBDA, evaluate the user-specified
429		# rotation criteron; return Q (the criterion) only
430	!	Q.current <- lav_matrix_rotate_mg_agreement(
431	!	lambdaList = lambdaList, method.fname = method.fname,
432	!	method.args = method.args,
433	!	mg.agreement.method = mg.agreement.method,
434	!	w = mg.agreement.weight, scale = scale
435		)
436
437		# if verbose, print
438	!	if (lav_verbose()) {
439	!	Q.mg <- attr(Q.current, "Q.mg")
440	!	A.mg <- attr(Q.current, "A.mg")
441	!	cat(
442	!	" iter = ", sprintf("%4d", 0),
443	!	" Q = ", sprintf("%13.11f", Q.current),
444	!	" Q.rot = ", sprintf("%13.11f", Q.mg),
445	!	" Q.agr = ", sprintf("%13.11f", A.mg), "\n"
446		)
447		}
448
449		# plane combinations
450	!	if (orthogonal) {
451	!	PLANE <- utils::combn(M, 2)
452		} else {
453	!	tmp <- utils::combn(M, 2)
454	!	PLANE <- cbind(tmp, tmp[c(2, 1), , drop = FALSE])
455		}
456
457		# define objective function -- orthogonal
458	!	objf_orth <- function(g = 1L, theta = 0, A = NULL, col1 = 0L, col2 = 0L) {
459		# construct ROT
460	!	ROT <- diag(M)
461	!	ROT[col1, col1] <- base::cos(theta)
462	!	ROT[col1, col2] <- base::sin(theta)
463	!	ROT[col2, col1] <- -1 * base::sin(theta)
464	!	ROT[col2, col2] <- base::cos(theta)
465
466		# rotate
467	!	lambdaList[[g]] <- A %*% ROT
468
469		# evaluate criterion
470	!	Q <- lav_matrix_rotate_mg_agreement(
471	!	lambdaList = lambdaList, method.fname = method.fname,
472	!	method.args = method.args, mg.agreement.method = mg.agreement.method,
473	!	w = mg.agreement.weight, scale = scale
474		)
475
476	!	Q
477		}
478
479		# define objective function -- oblique
480	!	objf_obliq <- function(g = 1, delta = 0, A = NULL, col1 = 0L, col2 = 0L,
481	!	psi12 = 0) {
482		# construct ROT
483	!	ROT <- diag(M)
484
485		# gamma
486	!	gamma2 <- 1 + (2 * delta * psi12) + (delta * delta)
487
488	!	ROT[col1, col1] <- sqrt(abs(gamma2))
489	!	ROT[col1, col2] <- -1 * delta
490	!	ROT[col2, col1] <- 0
491	!	ROT[col2, col2] <- 1
492
493		# rotate
494	!	lambdaList[[g]] <- A %*% ROT
495
496		# evaluate criterion
497	!	Q <- lav_matrix_rotate_mg_agreement(
498	!	lambdaList = lambdaList, method.fname = method.fname,
499	!	method.args = method.args, mg.agreement.method = mg.agreement.method,
500	!	w = mg.agreement.weight, scale = scale
501		)
502
503	!	Q
504		}
505
506		# start iterations
507	!	converged <- FALSE
508	!	Q.old <- Q.current
509	!	for (iter in seq_len(max.iter)) {
510		# for each group
511	!	for (g in seq_len(ngroups)) {
512		# rotate - one cycle
513	!	for (pl in seq_len(ncol(PLANE))) {
514		# choose plane
515	!	col1 <- PLANE[1, pl]
516	!	col2 <- PLANE[2, pl]
517
518		# optimize
519	!	if (orthogonal) {
520	!	out <- optimize(
521	!	f = objf_orth, interval = c(-pi / 4, +pi / 4),
522	!	g = g,
523	!	A = lambdaList[[g]], col1 = col1, col2 = col2,
524	!	maximum = FALSE, tol = .Machine$double.eps^0.25
525		)
526		# best rotation - for this plane
527	!	theta <- out$minimum
528
529		# construct ROT
530	!	ROT <- diag(M)
531	!	ROT[col1, col1] <- base::cos(theta)
532	!	ROT[col1, col2] <- base::sin(theta)
533	!	ROT[col2, col1] <- -1 * base::sin(theta)
534	!	ROT[col2, col2] <- base::cos(theta)
535		} else {
536	!	psi12 <- psiList[[g]][col1, col2]
537	!	out <- optimize(
538	!	f = objf_obliq, interval = c(-1, +1),
539	!	g = g,
540	!	A = lambdaList[[g]], col1 = col1, col2 = col2,
541	!	psi12 = psi12,
542	!	maximum = FALSE, tol = .Machine$double.eps^0.25
543		)
544
545		# best rotation - for this plane
546	!	delta <- out$minimum
547
548		# construct ROT
549	!	ROT <- diag(M)
550
551		# gamma
552	!	gamma2 <- 1 + (2 * delta * psi12) + (delta * delta)
553	!	gamma <- sqrt(abs(gamma2))
554
555	!	ROT[col1, col1] <- gamma
556	!	ROT[col1, col2] <- -1 * delta
557	!	ROT[col2, col1] <- 0
558	!	ROT[col2, col2] <- 1
559		}
560
561		# rotate
562	!	lambdaList[[g]] <- lambdaList[[g]] %*% ROT
563
564	!	if (!orthogonal) {
565	!	PSI <- psiList[[g]]
566		# rotate PSI
567	!	PSI[col1, ] <- (1 / gamma) * PSI[col1, ] + (delta / gamma) * PSI[col2, ]
568	!	PSI[, col1] <- PSI[col1, ]
569	!	PSI[col1, col1] <- 1
570	!	psiList[[g]] <- PSI
571		}
572		} # all planes
573		} # ngroups
574
575		# check for convergence
576	!	Q.current <- lav_matrix_rotate_mg_agreement(
577	!	lambdaList = lambdaList, method.fname = method.fname,
578	!	method.args = method.args, mg.agreement.method = mg.agreement.method,
579	!	w = mg.agreement.weight, scale = scale
580		)
581
582		# absolute change in Q
583	!	diff <- abs(Q.old - Q.current)
584
585		# if verbose, print
586	!	if (lav_verbose()) {
587	!	Q.mg <- attr(Q.current, "Q.mg")
588	!	A.mg <- attr(Q.current, "A.mg")
589	!	cat(
590	!	" iter = ", sprintf("%4d", iter),
591	!	" Q = ", sprintf("%13.11f", Q.current),
592	!	" Q.rot = ", sprintf("%13.11f", Q.mg),
593	!	" Q.agr = ", sprintf("%13.11f", A.mg),
594	!	" change = ", sprintf("%13.11f", diff), "\n"
595		)
596		}
597
598	!	if (!is.finite(diff)) {
599		# something went wrong ... bail out
600	!	lav_msg_warn(gettextf("mg-pairwise rotation algorithm failed!"))
601	!	break
602	!	} else if (diff < tol) {
603	!	converged <- TRUE
604	!	break
605		} else {
606	!	Q.old <- Q.current
607		}
608		} # iter
609
610		# warn if no convergence
611	!	if (!converged) {
612	!	lav_msg_warn(gettextf(
613	!	"mg-pairwise rotation algorithm did not converge after %s iterations",
614	!	max.iter
615		))
616		}
617
618		# compute final rotation matrix
619	!	rotList <- vector("list", length = ngroups)
620	!	if (orthogonal) {
621	!	for (g in seq_len(ngroups)) {
622	!	rotList[[g]] <- solve(
623	!	crossprod(Alist[[g]]),
624	!	crossprod(Alist[[g]], lambdaList[[g]])
625		)
626		}
627		} else {
628	!	for (g in seq_len(ngroups)) {
629		# to be compatible with GPa
630	!	ROTt.inv <- solve(
631	!	crossprod(Alist[[g]]),
632	!	crossprod(Alist[[g]], lambdaList[[g]])
633		)
634	!	rotList[[g]] <- solve(t(ROTt.inv))
635		}
636		}
637
638		# algorithm information
639	!	info <- list(
640	!	algorithm = "mg-pairwise",
641	!	iter = iter,
642	!	converged = converged,
643	!	method.value = Q.current
644		)
645
646	!	attr(rotList, "info") <- info
647
648	!	rotList
649		}

1		# compute model implied statistics
2		# per block
3
4		# YR 7 May 2022: add cov.x and mean.x if conditional.x (so that we do
5		# no longer depend on SampleStats)
6
7		lav_model_implied <- function(lavmodel = NULL, GLIST = NULL, delta = TRUE) {
8	7839x	stopifnot(inherits(lavmodel, "lavModel"))
9
10		# state or final?
11	180x	if (is.null(GLIST)) GLIST <- lavmodel@GLIST
12
13		# model-implied variance/covariance matrix ('sigma hat')
14	7839x	Sigma.hat <- lav_model_sigma(
15	7839x	lavmodel = lavmodel, GLIST = GLIST,
16	7839x	delta = delta
17		)
18
19		# model-implied mean structure ('mu hat')
20	7839x	if (lavmodel@meanstructure) {
21	6490x	Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST = GLIST)
22		} else {
23	1349x	Mu.hat <- vector("list", length = lavmodel@nblocks)
24		}
25
26		# if conditional.x, slopes, cov.x, mean.x
27	7839x	if (lavmodel@conditional.x) {
28	5819x	SLOPES <- lav_model_pi(lavmodel = lavmodel, GLIST = GLIST)
29
30		# per block, because for some blocks, cov.x may not exist
31	5819x	COV.X <- vector("list", lavmodel@nblocks)
32	5819x	MEAN.X <- vector("list", lavmodel@nblocks)
33	5819x	for (b in seq_len(lavmodel@nblocks)) {
34	5819x	mm.in.block <- (seq_len(lavmodel@nmat[b]) +
35	5819x	cumsum(c(0, lavmodel@nmat))[b])
36	5819x	MLIST <- lavmodel@GLIST[mm.in.block]
37	5819x	cov.x.idx <- which(names(MLIST) == "cov.x")
38	5819x	if (length(cov.x.idx) > 0L) {
39	5819x	COV.X[[b]] <- MLIST[[cov.x.idx]]
40		} else {
41	!	COV.X[[b]] <- matrix(0, 0L, 0L)
42		}
43	5819x	mean.x.idx <- which(names(MLIST) == "mean.x")
44	5819x	if (length(mean.x.idx) > 0L) {
45	5819x	MEAN.X[[b]] <- MLIST[[mean.x.idx]]
46		} else {
47	!	MEAN.X[[b]] <- matrix(0, 0L, 1L)
48		}
49		}
50		} else {
51	2020x	SLOPES <- vector("list", length = lavmodel@nblocks)
52		}
53
54		# if categorical, model-implied thresholds
55	7839x	if (lavmodel@categorical) {
56	5819x	TH <- lav_model_th(lavmodel = lavmodel, GLIST = GLIST)
57		} else {
58	2020x	TH <- vector("list", length = lavmodel@nblocks)
59		}
60
61	7839x	if (lavmodel@group.w.free) {
62	!	w.idx <- which(names(lavmodel@GLIST) == "gw")
63	!	GW <- unname(GLIST[w.idx])
64	!	GW <- lapply(GW, as.numeric)
65		} else {
66	7839x	GW <- vector("list", length = lavmodel@nblocks)
67		}
68
69	7839x	if (lavmodel@conditional.x) {
70	5819x	implied <- list(
71	5819x	res.cov = Sigma.hat, res.int = Mu.hat,
72	5819x	res.slopes = SLOPES, cov.x = COV.X, mean.x = MEAN.X,
73	5819x	res.th = TH, group.w = GW
74		)
75		} else {
76	2020x	implied <- list(cov = Sigma.hat, mean = Mu.hat, th = TH, group.w = GW)
77		}
78
79	7839x	implied
80		}
81
82		# convert 'conditional.x = TRUE' to 'conditional.x = FALSE'
83		lav_model_implied_cond2uncond <- function(lavimplied) {
84		# check for res.cov
85	7x	if (is.null(lavimplied$res.cov[[1]])) {
86		# already unconditional
87	7x	return(lavimplied)
88		} else {
89	!	nblocks <- length(lavimplied$res.cov)
90		}
91
92	!	COV <- vector("list", length = nblocks)
93	!	MEAN <- vector("list", length = nblocks)
94
95		# reconstruct COV/MEAN per block
96	!	for (b in seq_len(nblocks)) {
97	!	res.Sigma <- lavimplied$res.cov[[b]]
98	!	res.slopes <- lavimplied$res.slopes[[b]]
99	!	res.int <- lavimplied$res.int[[b]]
100	!	S.xx <- lavimplied$cov.x[[b]]
101	!	M.x <- lavimplied$mean.x[[b]]
102
103	!	S.yx <- res.slopes %*% S.xx
104	!	S.xy <- t(S.yx)
105	!	S.yy <- res.Sigma + tcrossprod(S.yx, res.slopes)
106	!	COV[[b]] <- rbind(cbind(S.yy, S.yx), cbind(S.xy, S.xx))
107
108	!	Mu.y <- as.vector(res.int + res.slopes %*% M.x)
109	!	Mu.x <- as.vector(M.x)
110	!	MEAN[[b]] <- matrix(c(Mu.y, Mu.x), ncol = 1L)
111		}
112
113		# we ignore res.th for now, as we do not support categorical data
114		# in the two-level setting anyway
115	!	implied <- list(
116	!	cov = COV, mean = MEAN, th = lavimplied$res.th,
117	!	group.w = lavimplied$group.w
118		)
119
120	!	implied
121		}

1		# only compute 'H1' (=unrestricted/saturated) sample statistics
2		# (which usually go into the lavh1 slot) (and perhaps some extras, like icc)
3		#
4		# YR 14 June 2024: initial version
5
6		lavH1 <- function(object, # nolint
7		# lavdata options
8		ordered = NULL,
9		sampling.weights = NULL,
10		group = NULL,
11		cluster = NULL,
12		ov.names.x = character(0L),
13		ov.names.l = list(),
14		# other options (for lavaan)
15		...,
16		output = "h1",
17		add.extra = TRUE,
18		# lavInspect() options
19		add.labels = TRUE,
20		add.class = TRUE,
21		drop.list.single.group = TRUE) {
22
23		# shortcut if object = lavaan object
24	!	if (inherits(object, "lavaan")) {
25	!	lavh1 <- lavInspect(object, "h1")
26		# if multilevel: add icc
27	!	if (add.extra && object@Data@nlevels > 1L) {
28	!	lavh1$icc <- lavInspect(object, "icc",
29	!	add.labels = add.labels,
30	!	add.class = add.class, drop.list.single.group = drop.list.single.group
31		)
32		}
33	!	return(lavh1)
34		}
35
36		# output
37	!	output <- tolower(output)
38
39		# dotdotdot
40	!	dotdotdot <- list(...)
41
42		# verbose?
43	!	if (!is.null(dotdotdot$verbose)) {
44	!	if (dotdotdot$verbose) {
45	!	lav_verbose(TRUE)
46		}
47	!	dotdotdot$verbose <- NULL
48		}
49
50		# check object class
51	!	if (inherits(object, "lavData")) {
52	!	lavdata <- object
53	!	} else if (inherits(object, "data.frame") \|\|
54	!	inherits(object, "matrix")) {
55	!	object <- as.data.frame(object)
56		} else {
57	!	lav_msg_stop(
58	!	gettext("lavH1 can not handle objects of class"),
59	!	paste(class(object), collapse = " ")
60		)
61		}
62
63		# prepare to create lavdata object
64	!	if (inherits(object, "lavData")) {
65	!	ov.names <- unique(unlist(lavdata@ov.names))
66	!	ov.names.x <- unique(unlist(lavdata@ov.names.x))
67	!	ordered <- lavdata@ordered
68	!	ov.names.l <- lavdata@ov.names.l
69	!	group <- lavdata@group
70	!	cluster <- lavdata@cluster
71	!	dotdotdot@missing <- lavdata@missing
72
73		# just a regular data.frame
74		} else {
75		# ov.names
76	!	ov.names <- names(object)
77	!	if (!is.null(group)) {
78	!	ov.names <- ov.names[-match(group, ov.names)]
79		}
80	!	if (!is.null(cluster)) {
81	!	ov.names <- ov.names[-match(cluster, ov.names)]
82		}
83	!	if (!is.null(sampling.weights)) {
84	!	ov.names <- ov.names[-match(sampling.weights, ov.names)]
85		}
86	!	if (!is.null(dotdotdot$conditional.x) && dotdotdot$conditional.x) {
87	!	if (length(ov.names.x) == 0L) {
88	!	lav_msg_stop(
89	!	gettext("conditional.x = TRUE, but ov.names.x is empty")
90		)
91		}
92	!	ov.names.x <- unique(unlist(ov.names.x))
93	!	ov.names <- ov.names[-match(ov.names.x, ov.names)]
94		}
95
96		# ordered
97	!	if (is.logical(ordered) && ordered) {
98	!	ordered <- ov.names
99	!	} else if (is.null(ordered) \|\|
100	!	(length(ordered) == 1L && nchar(ordered) == 0L)) {
101		# check data
102	!	ordered <- ov.names[sapply(object, is.ordered)]
103	!	} else if (!is.character(ordered)) {
104	!	lav_msg_stop(gettext("ordered argument must be a character vector"))
105		}
106
107	!	if (length(ordered) > 0L) {
108		# check if all names in "ordered" occur in the dataset?
109	!	missing.idx <- which(!ordered %in% ov.names)
110	!	if (length(missing.idx) > 0L) {
111	!	lav_msg_warn(gettextf("ordered variable(s): %s could not be found
112	!	in the data and will be ignored", lav_msg_view(ordered[missing.idx])))
113		}
114		# if ov.names.x, remove them from ordered (sanity check)
115	!	if (length(ov.names.x) > 0L) {
116	!	rm.idx <- which(ordered %in% ov.names.x)
117	!	if (length(rm.idx) > 0L) {
118	!	ordered <- ordered[-rm.idx]
119		}
120		}
121		}
122
123		# group/cluster
124	!	if (!is.null(cluster)) {
125	!	ngroups <- 1L
126	!	if (!is.null(group)) {
127	!	ngroups <- length(unique(object[, group]))
128		}
129	!	if (is.null(ov.names.l) \|\| length(ov.names.l) == 0L) {
130	!	ov.names.l <- vector("list", ngroups)
131		# only two levels for now
132	!	for (g in seq_len(ngroups)) {
133	!	ov.names.l[[g]] <- vector("list", 2L)
134	!	ov.names.l[[g]][[1]] <- ov.names
135	!	ov.names.l[[g]][[2]] <- ov.names
136		}
137		} else {
138		# check ov.names.l
139	!	if (!is.list(ov.names.l)) { # just a single vector of names?
140	!	ov.names.l <- rep(list(ov.names.l), 2L) # twolevels
141	!	} else if (length(ov.names.l) == ngroups &&
142	!	is.list(ov.names.l[[ngroups]])) {
143		} else {
144	!	ov.names.l <- rep(list(ov.names.l), ngroups)
145		}
146	!	tmp <- unique(unlist(ov.names.l))
147	!	if (!all(tmp %in% ov.names)) {
148	!	lav_msg_stop(gettextf(
149	!	"some variable names in ov.names.l
150	!	are missing: %1$s",
151	!	lav_msg_view(tmp[!tmp %in% ov.names])
152		))
153		}
154		}
155		}
156		} # object = data
157
158		# lavoptions
159	!	lavoptions <- lav_lavaan_step02_options(
160	!	slotOptions = NULL, # nolint
161	!	slotData = NULL, # nolint
162	!	flat.model = NULL,
163	!	ordered = ordered,
164	!	sample.cov = NULL,
165	!	sample.mean = NULL,
166	!	sample.th = NULL,
167	!	sample.nobs = NULL,
168	!	ov.names.l = ov.names.l,
169	!	sampling.weights = sampling.weights,
170	!	constraints = NULL,
171	!	group = group,
172	!	ov.names.x = ov.names.x,
173	!	ov.names.y = ov.names[!ov.names %in% ov.names.x],
174	!	dotdotdot = dotdotdot,
175	!	cluster = cluster,
176	!	data = "not.null"
177		)
178
179		# annoying: ov.names should not contain ov.names.x if categorical
180	!	if (length(ordered) > 0L && lavoptions$conditional.x) {
181	!	rm.idx <- which(ov.names %in% ov.names.x)
182	!	if (length(rm.idx) > 0L) {
183	!	ov.names <- ov.names[-rm.idx]
184		}
185		}
186
187		# create lavdata (if needed)
188	!	if (!inherits(object, "lavdata")) {
189	!	lavdata <- lav_lavdata(
190	!	data = object, group = group, cluster = cluster,
191	!	ov.names = ov.names, ordered = ordered,
192	!	sampling.weights = sampling.weights,
193	!	ov.names.x = ov.names.x, ov.names.l = ov.names.l,
194	!	lavoptions = lavoptions
195		)
196		}
197
198		# create SampleStats (needed for multilevel - YLp slot)
199	!	lavsamplestats <- lav_samplestats_from_data(
200	!	lavdata = lavdata,
201	!	lavoptions = lavoptions
202		)
203
204		# generate partable for unrestricted model
205	!	lavpartable.un <- lav_partable_unrestricted(
206	!	lavobject = NULL,
207	!	lavdata = lavdata,
208	!	lavsamplestats = lavsamplestats,
209	!	lavh1 = NULL,
210	!	lavoptions = lavoptions
211		)
212
213		# override some options
214	!	lavoptions$h1 <- TRUE
215	!	lavoptions$model.type <- "unrestricted"
216	!	lavoptions$start <- "simple" # we have a full ustart column in lavpartable.un
217	!	if (output != "lavaan") {
218	!	lavoptions$implied <- FALSE
219	!	lavoptions$loglik <- FALSE
220	!	lavoptions$postcheck <- FALSE
221	!	lavoptions$bounds <- "none"
222	!	lavoptions$optim.method <- "none"
223	!	lavoptions$estimator <- "none"
224	!	lavoptions$se <- "none"
225	!	lavoptions$test <- "none"
226	!	lavoptions$baseline <- FALSE
227		}
228
229		# create lavaan object (usually without fitting)
230	!	lavobject <- lavaan(
231	!	slotParTable = lavpartable.un, slotData = lavdata,
232	!	slotSampleStats = lavsamplestats, slotOptions = lavoptions
233		)
234
235	!	output <- tolower(output)
236	!	if (output == "lavaan") {
237	!	return(lavobject)
238		} else {
239	!	lavh1 <- lav_object_inspect_sampstat(
240	!	object = lavobject, h1 = TRUE,
241	!	add.labels = add.labels, add.class = add.class,
242	!	drop.list.single.group = drop.list.single.group
243		)
244
245		# add additional info?
246
247		# if multilevel: add icc
248	!	if (add.extra && lavobject@Data@nlevels > 1L) {
249	!	lavh1$icc <- lavInspect(lavobject, "icc",
250	!	add.labels = add.labels,
251	!	add.class = add.class, drop.list.single.group = drop.list.single.group
252		)
253		}
254		}
255
256	!	lavh1
257		}

1		# keep 'old' names for some function names that have been used
2		# (or are still being used) by external packages
3		# rsem
4		computeExpectedInformation <- lav_model_information_expected # nolint start
5		# only for simsem ....
6		getParameterLabels <- lav_partable_labels
7
8		# standardize function names in lav_utils.R / 31 Oct 2025
9		getCov <- function(x, lower = TRUE, diagonal = TRUE, sds = NULL,
10		names = paste("V", 1:nvar, sep = "")) {
11	2x	lav_deprecated("lav_getcov")
12	2x	if (diagonal) {
13	2x	nvar <- (sqrt(1 + 8 * length(x)) - 1)/2
14		}
15		else {
16	!	nvar <- (sqrt(1 + 8 * length(x)) + 1)/2
17		}
18	2x	sc <- sys.call()
19	2x	sc[[1L]] <- quote(lavaan::lav_getcov)
20	2x	eval(sc, parent.frame())
21		}
22		char2num <- function(s = "") {
23	!	lav_deprecated("lav_char2num")
24	!	sc <- sys.call()
25	!	sc[[1L]] <- quote(lavaan::lav_char2num)
26	!	eval(sc, parent.frame())
27		}
28		cor2cov <- function(R, sds, names = NULL) {
29	!	lav_deprecated("lav_cor2cov")
30	!	sc <- sys.call()
31	!	sc[[1L]] <- quote(lavaan::lav_cor2cov)
32	!	eval(sc, parent.frame())
33		}
34
35		# standardize function names in lav_mplus_lavaan / 7 Nov 2025
36		mplus2lavaan.modelSyntax <- function(syntax) {
37	!	lav_deprecated("lav_mplus_syntax_model")
38	!	sc <- sys.call()
39	!	sc[[1L]] <- quote(lavaan::lav_mplus_syntax_model)
40	!	eval(sc, parent.frame())
41		}
42		mplus2lavaan <- function(inpfile, run = TRUE) {
43	!	lav_deprecated("lav_mplus_lavaan")
44	!	sc <- sys.call()
45	!	sc[[1L]] <- quote(lavaan::lav_mplus_lavaan)
46	!	eval(sc, parent.frame())
47		}
48
49		# standardize function names in lav_partable_vnames.R / 9 December 2025
50		lavaanNames <- function(object, type = "ov", ...) {
51	!	lav_deprecated("lavNames", times = 0L) #--> for now no warning
52	!	sc <- sys.call()
53	!	sc[[1L]] <- quote(lavaan::lavNames)
54	!	eval(sc, parent.frame())
55		}
56
57		# standardize function names in lav_simulate_old.R / 9 December 2025
58		simulateData <- function(
59		model = NULL,
60		model.type = "sem",
61		meanstructure = FALSE,
62		int.ov.free = TRUE,
63		int.lv.free = FALSE,
64		marker.int.zero = FALSE,
65		conditional.x = FALSE,
66		composites = TRUE,
67		fixed.x = FALSE,
68		orthogonal = FALSE,
69		std.lv = TRUE,
70		auto.fix.first = FALSE,
71		auto.fix.single = FALSE,
72		auto.var = TRUE,
73		auto.cov.lv.x = TRUE,
74		auto.cov.y = TRUE,
75		...,
76		sample.nobs = 500L,
77		ov.var = NULL,
78		group.label = paste("G", 1:ngroups, sep = ""),
79		skewness = NULL,
80		kurtosis = NULL,
81		seed = NULL,
82		empirical = FALSE,
83		return.type = "data.frame",
84		return.fit = FALSE,
85		debug = FALSE,
86		standardized = FALSE) {
87	!	lav_deprecated("lavSimulateData", times = 0L) #--> for now no warning
88	!	if (is.list(model)) {
89	!	ngroups <- lav_partable_ngroups(model)
90		} else {
91	!	ngroups <- sample.nobs
92		}
93	!	sc <- sys.call()
94		# call new function
95	!	sc[[1L]] <- quote(lavaan::lavSimulateData)
96	!	eval(sc, parent.frame())
97		}
98		# standardize function names in lav_bootstrap.R / 9 December 2025
99		bootstrapLavaan <- function(object,
100		R = 1000L,
101		type = "ordinary",
102		verbose = FALSE,
103		FUN = "coef",
104		keep.idx = FALSE,
105		parallel = c("no", "multicore", "snow"),
106		ncpus = max(1L, parallel::detectCores() - 2L),
107		cl = NULL,
108		iseed = NULL,
109		h0.rmsea = NULL,
110		...) {
111	!	lav_deprecated("lavBootstrap", times = 0L) #--> for now no warning
112	!	sc <- sys.call()
113		# call new function
114	!	sc[[1L]] <- quote(lavaan::lavBootstrap)
115	!	eval(sc, parent.frame())
116		}
117
118		# standardize exported functions / 13 December 2025
119		inspectSampleCov <- function(model, data, ...) {
120	!	lav_deprecated("lavInspectSampleCov") #--> for now no warning
121	!	sc <- sys.call()
122	!	sc[[1L]] <- quote(lavaan::lavInspectSampleCov)
123	!	eval(sc, parent.frame())
124		} # nolint end
125
126		# parameterestimates <- function(object,
127		# se = TRUE, zstat = TRUE, pvalue = TRUE,
128		# ci = TRUE, standardized = FALSE,
129		# fmi = FALSE, plabel = FALSE,
130		# level = 0.95, boot.ci.type = "perc",
131		# cov.std = TRUE, fmi.options = list(),
132		# rsquare = FALSE,
133		# remove.system.eq = TRUE, remove.eq = TRUE,
134		# remove.ineq = TRUE, remove.def = FALSE,
135		# remove.nonfree = FALSE, remove.step1 = TRUE,
136		# remove.unused = FALSE, add.attributes = FALSE,
137		# output = "data.frame", header = FALSE) {
138		# lav_deprecated("lavParameterEstimates", times = 1L) #--> for now no warning
139		# sc <- sys.call()
140		# sc[[1L]] <- quote(lavaan::lavParameterEstimates)
141		# eval(sc, parent.frame())
142		# }
143		parameterestimates <- parameterEstimates # alias
144
145		# for tidySEM in 0.6-21 only
146		# vnames <- lav_partable_vnames

1		# James-Stein estimator
2		#
3		# Burghgraeve, E., De Neve, J., & Rosseel, Y. (2021). Estimating structural
4		# equation models using James-Stein type shrinkage estimators. Psychometrika,
5		# 86(1), 96-130.
6		#
7		# YR 08 Feb 2023: - first version in lavaan, cfa only (for now)
8
9		lav_cfa_jamesstein <- function(S,
10		Y = NULL, # raw data
11		marker.idx = NULL,
12		lambda.nonzero.idx = NULL,
13		theta = NULL, # vector!
14		theta.bounds = TRUE,
15		aggregated = FALSE) { # aggregated?
16		# dimensions
17	!	nvar <- ncol(S)
18	!	nfac <- length(marker.idx)
19	!	stopifnot(length(theta) == nvar)
20	!	N <- nrow(Y)
21	!	stopifnot(ncol(Y) == nvar)
22
23		# overview of lambda structure
24	!	B <- LAMBDA <- B.nomarker <- matrix(0, nvar, nfac)
25	!	lambda.marker.idx <- (seq_len(nfac) - 1L) * nvar + marker.idx
26	!	B[lambda.marker.idx] <- LAMBDA[lambda.marker.idx] <- 1L
27	!	B[lambda.nonzero.idx] <- B.nomarker[lambda.nonzero.idx] <- 1L
28
29		# Nu
30	!	NU <- numeric(nvar)
31
32		# do we first 'clip' the theta values so they are within standard bounds?
33		# (Question: do we need the 0.01 and 0.99 multipliers?)
34	!	diagS <- diag(S)
35	!	if (theta.bounds) {
36		# lower bound
37	!	lower.bound <- diagS * 0 # * 0.01
38	!	too.small.idx <- which(theta < lower.bound)
39	!	if (length(too.small.idx) > 0L) {
40	!	theta[too.small.idx] <- lower.bound[too.small.idx]
41		}
42
43		# upper bound
44	!	upper.bound <- diagS * 1 # * 0.99
45	!	too.large.idx <- which(theta > upper.bound)
46	!	if (length(too.large.idx) > 0L) {
47	!	theta[too.large.idx] <- upper.bound[too.large.idx]
48		}
49		}
50
51		# compute conditional expectation conditional on the scaling indicator
52	!	E.JS1 <- lav_cfa_jamesstein_ce(
53	!	Y = Y, marker.idx = marker.idx,
54	!	resvars.markers = theta[marker.idx]
55		)
56
57		# compute LAMBDA
58	!	for (f in seq_len(nfac)) {
59	!	nomarker.idx <- which(B.nomarker[, f] == 1)
60	!	Y.nomarker.f <- Y[, nomarker.idx, drop = FALSE]
61
62		# regress no.marker.idx data on E(\eta\|Y)
63	!	fit <- lm(Y.nomarker.f ~ E.JS1[, f, drop = FALSE])
64
65		# extract 'lambda' values
66	!	LAMBDA[nomarker.idx, f] <- drop(coef(fit)[-1, ])
67
68		# (optional) extract means
69		# NU[nomarker.idx] <- drop(coef(fit)[1,])
70
71	!	if (aggregated) {
72		# local copy of 'scaling' LAMBDA
73	!	LAMBDA.scaling <- LAMBDA
74
75	!	J <- length(nomarker.idx)
76	!	for (j in seq_len(J)) {
77		# data without this indicator
78	!	j.idx <- nomarker.idx[j]
79	!	no.j.idx <- c(marker.idx[f], nomarker.idx[-j])
80	!	Y.agg <- Y[, no.j.idx, drop = FALSE]
81	!	Y.j <- Y[, j.idx, drop = FALSE]
82
83		# retrieve estimated values scaling JS
84	!	lambda.JS.scaling <- LAMBDA.scaling[no.j.idx, f, drop = FALSE]
85
86		# optimize the weights
87	!	starting.weights <- rep(1 / J, times = J)
88	!	w <- optim(
89	!	par = starting.weights,
90	!	fn = lav_cfa_jamesstein_rel,
91	!	data = Y.agg,
92	!	resvars = theta[no.j.idx]
93	!	)$par
94
95		# make sure the weights sum up to 1
96	!	w.optim <- w / sum(w)
97
98		# compute aggregated indicator using the optimal weights
99	!	y_agg <- t(t(w.optim) %*% t(Y.agg))
100
101		# compute error variance of the aggregated indicator
102	!	var_eps_agg <- drop(t(w.optim) %*%
103	!	diag(theta[no.j.idx], nrow = length(no.j.idx)) %*% w.optim)
104
105		# compute conditional expectation using aggregated indicator
106	!	tmp <- lav_cfa_jamesstein_ce(
107	!	Y = y_agg, marker.idx = 1L,
108	!	resvars.markers = var_eps_agg
109		)
110	!	CE_agg <- tmp / drop(w.optim %*% lambda.JS.scaling)
111
112		# compute factor loading
113	!	fit <- lm(Y.j ~ CE_agg)
114	!	LAMBDA[j.idx, f] <- drop(coef(fit)[-1])
115
116		# (optional) extract means
117		# NU[j.idx] <- drop(coef(fit)[1,])
118		} # j
119		} # aggregate
120		} # f
121
122	!	out <- list(lambda = LAMBDA, nu = NU)
123		}
124
125		# internal function to be used inside lav_optim_noniter
126		# return 'x', the estimated vector of free parameters
127		lav_cfa_jamesstein_internal <- function(lavobject = NULL, # convenience
128		# internal slot
129		lavmodel = NULL,
130		lavsamplestats = NULL,
131		lavpartable = NULL,
132		lavdata = NULL,
133		lavoptions = NULL,
134		theta.bounds = TRUE) {
135	!	lavpta <- NULL
136	!	if (!is.null(lavobject)) {
137	!	stopifnot(inherits(lavobject, "lavaan"))
138
139		# extract slots
140	!	lavmodel <- lavobject@Model
141	!	lavsamplestats <- lavobject@SampleStats
142	!	lavpartable <- lav_partable_set_cache(lavobject@ParTable, lavobject@pta)
143	!	lavpta <- lavobject@pta
144	!	lavdata <- lavobject@Data
145	!	lavoptions <- lavobject@Options
146		}
147	!	if (is.null(lavpta)) {
148	!	lavpta <- lav_partable_attributes(lavpartable)
149	!	lavpartable <- lav_partable_set_cache(lavpartable, lavpta)
150		}
151
152		# no structural part!
153	!	if (any(lavpartable$op == "~")) {
154	!	lav_msg_stop(gettext(
155	!	"JS(A) estimator only available for CFA models (for now)"))
156		}
157		# no BETA matrix! (i.e., no higher-order factors)
158	!	if (!is.null(lavmodel@GLIST$beta)) {
159	!	lav_msg_stop(gettext(
160	!	"JS(A) estimator not available for models that require a BETA matrix"))
161		}
162		# no std.lv = TRUE for now
163	!	if (lavoptions$std.lv) {
164	!	lav_msg_stop(gettext("S(A) estimator not available if std.lv = TRUE"))
165		}
166
167	!	nblocks <- lav_partable_nblocks(lavpartable)
168	!	stopifnot(nblocks == 1L) # for now
169	!	b <- 1L
170	!	sample.cov <- lavsamplestats@cov[[b]]
171	!	nvar <- nrow(sample.cov)
172	!	lv.names <- lavpta$vnames$lv.regular[[b]]
173	!	nfac <- length(lv.names)
174	!	marker.idx <- lavpta$vidx$lv.marker[[b]]
175	!	lambda.idx <- which(names(lavmodel@GLIST) == "lambda")
176	!	lambda.nonzero.idx <- lavmodel@m.free.idx[[lambda.idx]]
177		# only diagonal THETA for now...
178	!	theta.idx <- which(names(lavmodel@GLIST) == "theta") # usually '2'
179	!	m.theta <- lavmodel@m.free.idx[[theta.idx]]
180	!	nondiag.idx <- m.theta[!m.theta %in% lav_matrix_diag_idx(nvar)]
181	!	if (length(nondiag.idx) > 0L) {
182	!	lav_msg_warn(gettext(
183	!	"this implementation of JS/JSA does not handle correlated residuals yet!"
184		))
185		}
186
187
188		# 1. obtain estimate for (diagonal elements of) THETA
189		# for now we use Spearman per factor
190	!	B <- matrix(0, nvar, nfac)
191	!	lambda.marker.idx <- (seq_len(nfac) - 1L) * nvar + marker.idx
192	!	B[lambda.marker.idx] <- 1L
193	!	B[lambda.nonzero.idx] <- 1L
194	!	theta <- numeric(nvar)
195	!	for (f in seq_len(nfac)) {
196	!	ov.idx <- which(B[, f] == 1L)
197	!	S.fac <- sample.cov[ov.idx, ov.idx, drop = FALSE]
198	!	theta[ov.idx] <- lav_cfa_theta_spearman(S.fac, bounds = "wide")
199		}
200	!	THETA <- diag(theta, nrow = nvar)
201
202		# 2. run James-Stein algorithm
203	!	Y <- lavdata@X[[1]] # raw data
204	!	aggregated <- FALSE
205	!	if (lavoptions$estimator == "JSA") {
206	!	aggregated <- TRUE
207		}
208	!	out <- lav_cfa_jamesstein(
209	!	S = sample.cov, Y = Y, marker.idx = marker.idx,
210	!	lambda.nonzero.idx = lambda.nonzero.idx,
211	!	theta = theta,
212		# experimental
213	!	theta.bounds = theta.bounds,
214		#
215	!	aggregated = aggregated
216		)
217	!	LAMBDA <- out$lambda
218
219		# 3. PSI
220	!	PSI <- lav_cfa_lambdatheta2psi(
221	!	lambda = LAMBDA, theta = theta,
222	!	S = sample.cov, mapping = "ML"
223		)
224
225		# store matrices in lavmodel@GLIST
226	!	lavmodel@GLIST$lambda <- LAMBDA
227	!	lavmodel@GLIST$theta <- THETA
228	!	lavmodel@GLIST$psi <- PSI
229
230		# extract free parameters only
231	!	x <- lav_model_get_parameters(lavmodel)
232
233		# apply bounds (if any)
234	!	if (!is.null(lavpartable$lower)) {
235	!	lower.x <- lavpartable$lower[lavpartable$free > 0]
236	!	too.small.idx <- which(x < lower.x)
237	!	if (length(too.small.idx) > 0L) {
238	!	x[too.small.idx] <- lower.x[too.small.idx]
239		}
240		}
241	!	if (!is.null(lavpartable$upper)) {
242	!	upper.x <- lavpartable$upper[lavpartable$free > 0]
243	!	too.large.idx <- which(x > upper.x)
244	!	if (length(too.large.idx) > 0L) {
245	!	x[too.large.idx] <- upper.x[too.large.idx]
246		}
247		}
248
249	!	x
250		}
251
252
253		# Conditional expectation (Section 2.1, eq. 10)
254		lav_cfa_jamesstein_ce <- function(Y = NULL,
255		marker.idx = NULL,
256		resvars.markers = NULL) {
257	!	Y <- as.matrix(Y)
258
259		# sample size
260	!	N <- nrow(Y)
261	!	N1 <- N - 1
262	!	N3 <- N - 3
263
264		# markers only
265	!	Y.marker <- Y[, marker.idx, drop = FALSE]
266
267		# means and variances
268	!	MEAN <- colMeans(Y.marker, na.rm = TRUE)
269	!	VAR <- apply(Y.marker, 2, var, na.rm = TRUE)
270
271		# 1 - R per maker
272	!	oneminR <- N3 * resvars.markers / (N1 * VAR)
273
274		# R per marker
275	!	R <- 1 - oneminR
276
277		# create E(\eta \| Y)
278	!	E.eta.cond.Y <- t(t(Y.marker) * R + oneminR * MEAN)
279
280	!	E.eta.cond.Y
281		}
282
283		# Reliability function used to obtain the weights (Section 4, Aggregation)
284		lav_cfa_jamesstein_rel <- function(w = NULL, data = NULL, resvars = NULL) {
285		# construct weight vector
286	!	w <- matrix(w, ncol = 1)
287
288		# construct aggregated indicator: y_agg = t(w) %*% y_i
289	!	y_agg <- t(t(w) %*% t(data))
290
291		# calculate variance of aggregated indicator
292	!	var_y_agg <- var(y_agg)
293
294		# calculate error variance of the aggregated indicator
295	!	var_eps_agg <- t(w) %% diag(resvars) %% w
296
297		# reliability function to be maximized
298	!	rel <- (var_y_agg - var_eps_agg) %*% solve(var_y_agg)
299
300		# return value
301	!	return(-rel)
302		}

1		# classic score test (= Lagrange Multiplier test)
2		#
3		# this function can run in two modes:
4		#
5		# MODE 1: 'add'
6		# add new parameters that are currently not included in de model
7		# (aka fixed to zero), but should be released
8		#
9		# MODE 2: 'release' (the default)
10		# release existing "==" constraints
11		#
12		# - YR 8 Jan 2026: use ceq.JAC instead of con.jac (as we do not support
13		# inequality constraints anyway, and we do not want to
14		# release the EFA constraints)
15
16		lavTestScore <- function(object, add = NULL, release = NULL,
17		univariate = TRUE, cumulative = FALSE,
18		epc = FALSE, standardized = epc, cov.std = epc,
19		verbose = FALSE, warn = TRUE,
20		information = "expected") {
21		# check object
22	!	object <- lav_object_check_version(object)
23
24	!	if (!missing(warn)) {
25	!	current.warn <- lav_warn()
26	!	if (lav_warn(warn))
27	!	on.exit(lav_warn(current.warn))
28		}
29	!	if (!missing(verbose)) {
30	!	current.verbose <- lav_verbose()
31	!	if (lav_verbose(verbose))
32	!	on.exit(lav_verbose(current.verbose), TRUE)
33		}
34		# check object
35	!	stopifnot(inherits(object, "lavaan"))
36	!	lavoptions <- object@Options
37
38	!	if (object@optim$npar > 0L && !object@optim$converged) {
39	!	lav_msg_stop(gettext("model did not converge"))
40		}
41
42		# check for inequality constraints
43	!	PT <- object@ParTable
44	!	if (any(PT$op == ">" \| PT$op == "<")) {
45	!	lav_msg_stop(gettext(
46	!	"lavTestScore() does not handle inequality constraints (yet)"))
47		}
48
49		# check arguments
50	!	if (cumulative) {
51	!	univariate <- TRUE
52		}
53
54
55		# Mode 1: ADDING new parameters
56	!	if (!is.null(add) && all(nchar(add) > 0L)) {
57		# check release argument
58	!	if (!is.null(release)) {
59	!	lav_msg_stop(gettext(
60	!	"`add' and `release' arguments cannot be used together."))
61		}
62
63		# extend model with extra set of parameters
64	!	FIT <- lav_object_extended(object, add = add)
65
66	!	score <- lavTech(FIT, "gradient.logl")
67	!	Information <- lavTech(FIT, paste("information", information, sep = "."))
68
69	!	npar <- object@Model@nx.free
70	!	nadd <- FIT@Model@nx.free - npar
71
72		# R
73	!	R.model <- object@Model@ceq.JAC[, , drop = FALSE]
74	!	if (nrow(R.model) > 0L) {
75	!	R.model <- cbind(R.model, matrix(0, nrow(R.model), ncol = nadd))
76	!	R.add <- cbind(matrix(0, nrow = nadd, ncol = npar), diag(nadd))
77	!	R <- rbind(R.model, R.add)
78
79	!	Z <- cbind(
80	!	rbind(Information, R.model),
81	!	rbind(t(R.model), matrix(0, nrow(R.model), nrow(R.model)))
82		)
83	!	Z.plus <- MASS::ginv(Z)
84	!	J.inv <- Z.plus[1:nrow(Information), 1:nrow(Information)]
85
86	!	r.idx <- seq_len(nadd) + nrow(R.model)
87		} else {
88	!	R <- cbind(matrix(0, nrow = nadd, ncol = npar), diag(nadd))
89	!	J.inv <- MASS::ginv(Information)
90
91	!	r.idx <- seq_len(nadd)
92		}
93
94		# lhs/rhs
95	!	lhs <- lav_partable_labels(FIT@ParTable)[FIT@ParTable$user == 10L]
96	!	op <- rep("==", nadd)
97	!	rhs <- rep("0", nadd)
98	!	Table <- data.frame(
99	!	lhs = lhs, op = op, rhs = rhs,
100	!	stringsAsFactors = FALSE
101		)
102	!	class(Table) <- c("lavaan.data.frame", "data.frame")
103		} else {
104		# MODE 2: releasing constraints
105
106	!	R <- object@Model@ceq.JAC[, , drop = FALSE]
107	!	if (nrow(R) == 0L) {
108	!	lav_msg_stop(gettext("no equality constraints found in model."))
109		}
110
111	!	score <- lavTech(object, "gradient.logl")
112	!	Information <- lavTech(
113	!	object,
114	!	paste("information", information, sep = ".")
115		)
116	!	J.inv <- MASS::ginv(Information) # FIXME: move into if(is.null(release))?
117		# else written over with Z1.plus if(is.numeric(release))
118		# R <- object@Model@con.jac[,]
119
120	!	if (is.null(release)) {
121		# ALL constraints
122	!	r.idx <- seq_len(nrow(R))
123	!	} else if (is.numeric(release)) {
124	!	r.idx <- release
125	!	if (max(r.idx) > nrow(R)) {
126	!	lav_msg_stop(gettextf(
127	!	"maximum constraint number (%1$s) is larger than number of
128	!	constraints (%2$s)", max(r.idx), nrow(R)))
129		}
130
131		# neutralize the non-needed constraints
132	!	R1 <- R[-r.idx, , drop = FALSE]
133	!	Z1 <- cbind(
134	!	rbind(Information, R1),
135	!	rbind(t(R1), matrix(0, nrow(R1), nrow(R1)))
136		)
137	!	Z1.plus <- MASS::ginv(Z1)
138	!	J.inv <- Z1.plus[1:nrow(Information), 1:nrow(Information)]
139	!	} else if (is.character(release)) {
140	!	lav_msg_stop(gettext("not implemented yet"))
141		}
142
143		# lhs/rhs
144	!	eq.idx <- which(object@ParTable$op == "==")
145	!	if (length(eq.idx) > 0L) {
146	!	lhs <- object@ParTable$lhs[eq.idx][r.idx]
147	!	op <- rep("==", length(r.idx))
148	!	rhs <- object@ParTable$rhs[eq.idx][r.idx]
149		}
150	!	Table <- data.frame(
151	!	lhs = lhs, op = op, rhs = rhs,
152	!	stringsAsFactors = FALSE
153		)
154	!	class(Table) <- c("lavaan.data.frame", "data.frame")
155		}
156
157	!	if (object@Data@nlevels == 1L) {
158	!	N <- object@SampleStats@ntotal
159	!	if (lavoptions$mimic == "EQS") {
160	!	N <- N - 1
161		}
162		} else {
163		# total number of clusters (over groups)
164	!	N <- 0
165	!	for (g in 1:object@SampleStats@ngroups) {
166	!	N <- N + object@Data@Lp[[g]]$nclusters[[2]]
167		}
168		# score <- score * (2 * object@SampleStats@ntotal) / N
169	!	score <- score / 2 # -2 * LRT
170		}
171
172	!	if (lavoptions$se == "standard") {
173	!	stat <- as.numeric(N * score %% J.inv %% score)
174		} else {
175		# generalized score test
176	!	lav_msg_warn(gettext("se is not `standard'; not implemented yet;
177	!	falling back to ordinary score test"))
178
179		# NOTE!!!
180		# we can NOT use VCOV here, because it reflects the constraints,
181		# and the whole point is to test for these constraints...
182
183	!	stat <- as.numeric(N * score %% J.inv %% score)
184		}
185
186		# compute df, taking into account that some of the constraints may
187		# be needed to identify the model (and hence Information is singular)
188		# Information.plus <- Information + crossprod(R)
189		# df <- qr(R[r.idx,,drop = FALSE])$rank +
190		# ( qr(Information)$rank - qr(Information.plus)$rank )
191	!	df <- nrow(R[r.idx, , drop = FALSE])
192	!	pvalue <- 1 - pchisq(stat, df = df)
193
194		# total score test
195	!	TEST <- data.frame(
196	!	test = "score", X2 = stat, df = df, p.value = pvalue,
197	!	stringsAsFactors = FALSE
198		)
199	!	class(TEST) <- c("lavaan.data.frame", "data.frame")
200	!	attr(TEST, "header") <- "total score test:"
201
202	!	OUT <- list(test = TEST)
203
204	!	if (univariate) {
205	!	TS <- numeric(nrow(R))
206	!	EPC.uni <- numeric(nrow(R)) # ignored in release= mode
207	!	for (r in r.idx) {
208	!	R1 <- R[-r, , drop = FALSE]
209	!	Z1 <- cbind(
210	!	rbind(Information, R1),
211	!	rbind(t(R1), matrix(0, nrow(R1), nrow(R1)))
212		)
213	!	Z1.plus <- MASS::ginv(Z1)
214	!	Z1.plus1 <- Z1.plus[1:nrow(Information), 1:nrow(Information)]
215	!	TS[r] <- as.numeric(N * t(score) %% Z1.plus1 %% score)
216	!	if (epc && !is.null(add)) {
217		# EPC.uni[r] <- -1 * utils::tail(as.numeric(score %*% Z1.plus1),
218		# n = nrow(R))[r]
219		# to keep the 'sign' consistent with modindices(), which
220		# uses epc = 'new - old'
221	!	EPC.uni[r] <- +1 * utils::tail(as.numeric(score %*% Z1.plus1),
222	!	n = nrow(R)
223	!	)[r]
224		}
225		}
226
227	!	Table2 <- Table
228	!	Table2$X2 <- TS[r.idx]
229	!	Table2$df <- rep(1, length(r.idx))
230	!	Table2$p.value <- 1 - pchisq(Table2$X2, df = Table2$df)
231	!	if (epc && !is.null(add)) {
232	!	Table2$epc <- EPC.uni[r.idx]
233		}
234	!	attr(Table2, "header") <- "univariate score tests:"
235	!	OUT$uni <- Table2
236		}
237
238	!	if (cumulative) {
239	!	TS.order <- sort.int(TS, index.return = TRUE, decreasing = TRUE)$ix
240	!	ROW.order <- sort.int(TS[r.idx], index.return = TRUE, decreasing = TRUE)$ix
241	!	TS <- numeric(length(r.idx))
242	!	for (r in 1:length(r.idx)) {
243	!	rcumul.idx <- TS.order[1:r]
244
245	!	R1 <- R[-rcumul.idx, , drop = FALSE]
246	!	Z1 <- cbind(
247	!	rbind(Information, R1),
248	!	rbind(t(R1), matrix(0, nrow(R1), nrow(R1)))
249		)
250	!	Z1.plus <- MASS::ginv(Z1)
251	!	Z1.plus1 <- Z1.plus[1:nrow(Information), 1:nrow(Information)]
252	!	TS[r] <- as.numeric(N * t(score) %% Z1.plus1 %% score)
253		}
254
255	!	Table3 <- Table[ROW.order, ]
256	!	Table3$X2 <- TS
257	!	Table3$df <- seq_len(length(TS))
258	!	Table3$p.value <- 1 - pchisq(Table3$X2, df = Table3$df)
259	!	attr(Table3, "header") <- "cumulative score tests:"
260	!	OUT$cumulative <- Table3
261		}
262
263	!	if (epc) {
264		# EPC <- vector("list", length = length(r.idx))
265		# for(i in 1:length(r.idx)) {
266		# r <- r.idx[i]
267		# R1 <- R[-r,,drop = FALSE]
268		# Z1 <- cbind( rbind(Information, R1),
269		# rbind(t(R1), matrix(0,nrow(R1),nrow(R1))) )
270		# Z1.plus <- MASS::ginv(Z1)
271		# Z1.plus1 <- Z1.plus[ 1:nrow(Information), 1:nrow(Information) ]
272		# EPC[[i]] <- -1 * as.numeric(score %*% Z1.plus1)
273		# }
274		#
275		# OUT$EPC <- EPC
276
277		# alltogether
278	!	R1 <- R[-r.idx, , drop = FALSE]
279	!	Z1 <- cbind(
280	!	rbind(Information, R1),
281	!	rbind(t(R1), matrix(0, nrow(R1), nrow(R1)))
282		)
283	!	Z1.plus <- MASS::ginv(Z1)
284	!	Z1.plus1 <- Z1.plus[1:nrow(Information), 1:nrow(Information)]
285		# EPC.all <- -1 * as.numeric(score %*% Z1.plus1)
286		# to keep the 'sign' consistent with modindices(), which
287		# uses epc = 'new - old'
288	!	EPC.all <- +1 * as.numeric(score %*% Z1.plus1)
289
290		# create epc table for the 'free' parameters
291	!	if (!is.null(add) && all(nchar(add) > 0L)) {
292	!	LIST <- parTable(FIT)
293		} else {
294		## release mode
295	!	LIST <- parTable(object)
296		}
297	!	if (lav_partable_ngroups(LIST) == 1L) {
298	!	LIST$group <- NULL
299		}
300	!	nonpar.idx <- which(LIST$op %in% c("==", ":=", "<", ">"))
301	!	if (length(nonpar.idx) > 0L) {
302	!	LIST <- LIST[-nonpar.idx, ]
303		}
304
305	!	LIST$est[LIST$free > 0 & LIST$user != 10] <- lav_object_inspect_coef(object, type = "free")
306	!	LIST$est[LIST$user == 10L] <- 0
307	!	LIST$epc <- rep(as.numeric(NA), length(LIST$lhs))
308	!	LIST$epc[LIST$free > 0] <- EPC.all
309	!	LIST$epv <- LIST$est + LIST$epc
310
311	!	if (standardized) {
312	!	EPC <- LIST$epc
313
314	!	if (cov.std) {
315		# replace epc values for variances by est values
316	!	var.idx <- which(LIST$op == "~~" & LIST$lhs == LIST$rhs &
317	!	LIST$exo == 0L)
318	!	EPC[var.idx] <- LIST$est[var.idx]
319		}
320
321		# two problems:
322		# - EPC of variances can be negative, and that is
323		# perfectly legal
324		# - EPC (of variances) can be tiny (near-zero), and we should
325		# not divide by tiny variables
326	!	small.idx <- which(LIST$op == "~~" &
327	!	LIST$lhs == LIST$rhs &
328	!	abs(EPC) < sqrt(.Machine$double.eps))
329	!	if (length(small.idx) > 0L) {
330	!	EPC[small.idx] <- as.numeric(NA)
331		}
332
333		# get the sign
334	!	EPC.sign <- sign(LIST$epc)
335
336	!	LIST$sepc.lv <- EPC.sign * lav_standardize_lv(object,
337	!	partable = LIST,
338	!	est = abs(EPC),
339	!	cov.std = cov.std
340		)
341	!	if (length(small.idx) > 0L) {
342	!	LIST$sepc.lv[small.idx] <- 0
343		}
344	!	LIST$sepc.all <- EPC.sign * lav_standardize_all(object,
345	!	partable = LIST,
346	!	est = abs(EPC),
347	!	cov.std = cov.std
348		)
349	!	if (length(small.idx) > 0L) {
350	!	LIST$sepc.all[small.idx] <- 0
351		}
352	!	LIST$sepc.nox <- EPC.sign * lav_standardize_all_nox(object,
353	!	partable = LIST,
354	!	est = abs(EPC),
355	!	cov.std = cov.std
356		)
357	!	if (length(small.idx) > 0L) {
358	!	LIST$sepc.nox[small.idx] <- 0
359		}
360		}
361
362	!	LIST$free[LIST$user == 10L] <- 0
363	!	LIST$user <- NULL
364		# remove some more columns
365	!	LIST$id <- LIST$ustart <- LIST$exo <- LIST$start <- LIST$se <- LIST$prior <- NULL
366	!	if (lav_partable_nblocks(LIST) == 1L) {
367	!	LIST$block <- NULL
368	!	LIST$group <- NULL
369	!	LIST$level <- NULL
370		}
371
372	!	attr(LIST, "header") <- "expected parameter changes (epc) and expected parameter values (epv):"
373
374	!	OUT$epc <- LIST
375		}
376
377	!	OUT
378		}

1		# univariate modification indices
2		#
3
4		modindices <- function(object,
5		standardized = TRUE,
6		cov.std = TRUE,
7		information = "expected",
8		# power statistics?
9		power = FALSE,
10		delta = 0.1,
11		alpha = 0.05,
12		high.power = 0.75,
13		# customize output
14		sort. = FALSE,
15		minimum.value = 0.0,
16		maximum.number = nrow(LIST),
17		free.remove = TRUE,
18		na.remove = TRUE,
19		op = NULL) {
20		# check object
21	!	object <- lav_object_check_version(object)
22
23		# check if model has converged
24	!	if (object@optim$npar > 0L && !object@optim$converged) {
25	!	lav_msg_warn(gettext("model did not converge"))
26		}
27
28		# not ready for estimator = "PML"
29	!	if (object@Options$estimator == "PML") {
30	!	lav_msg_stop(gettext(
31	!	"modification indices for estimator PML are not implemented yet."))
32		}
33
34		# new in 0.6-17: check if the model contains equality constraints
35	!	if (object@Model@eq.constraints) {
36	!	lav_msg_warn(
37	!	gettext("the modindices() function ignores equality constraints;
38	!	use lavTestScore() to assess the impact of releasing one or
39	!	multiple constraints.")
40		)
41		}
42
43		# sanity check
44	!	if (power) {
45	!	standardized <- TRUE
46		}
47
48		# extended list (fixed-to-zero parameters)
49	!	strict.exo <- FALSE
50	!	if (object@Model@conditional.x) {
51	!	strict.exo <- TRUE
52		}
53	!	FULL <- lav_partable_full(
54	!	partable = lav_partable_set_cache(object@ParTable, object@pta),
55	!	free = TRUE, start = TRUE,
56	!	strict.exo = strict.exo
57		)
58	!	FULL$free <- rep(1L, nrow(FULL))
59	!	FULL$user <- rep(10L, nrow(FULL))
60
61	!	FIT <- lav_object_extended(object, add = FULL, all.free = TRUE)
62	!	LIST <- FIT@ParTable
63
64
65		# compute information matrix 'extended model'
66		# ALWAYS use expected information (for now)
67	!	Information <- lavTech(FIT, paste("information", information, sep = "."))
68
69		# compute gradient 'extended model'
70	!	score <- lavTech(FIT, "gradient.logl")
71
72		# Saris, Satorra & Sorbom 1987
73		# partition Q into Q_11, Q_22 and Q_12/Q_21
74		# which elements of Q correspond with 'free' and 'nonfree' parameters?
75	!	model.idx <- LIST$free[LIST$free > 0L & LIST$user != 10L]
76	!	extra.idx <- LIST$free[LIST$free > 0L & LIST$user == 10L]
77
78		# catch empty extra.idx (no modification indices!)
79	!	if (length(extra.idx) == 0L) {
80		# 2 possibilities: either model is saturated, or we have constraints
81	!	if (object@test[[1]]$df == 0) {
82	!	lav_msg_warn(gettext(
83	!	"list with extra parameters is empty; model is saturated"))
84		} else {
85	!	lav_msg_warn(gettext(
86	!	"list with extra parameters is empty; to release equality
87	!	constraints, use lavTestScore()"))
88		}
89	!	LIST <- data.frame(
90	!	lhs = character(0), op = character(0),
91	!	rhs = character(0), group = integer(0),
92	!	mi = numeric(0), epc = numeric(0),
93	!	sepc.lv = numeric(0), sepc.all = numeric(0),
94	!	sepc.nox = numeric(0)
95		)
96	!	return(LIST)
97		}
98
99		# partition
100	!	I11 <- Information[extra.idx, extra.idx, drop = FALSE]
101	!	I12 <- Information[extra.idx, model.idx, drop = FALSE]
102	!	I21 <- Information[model.idx, extra.idx, drop = FALSE]
103	!	I22 <- Information[model.idx, model.idx, drop = FALSE]
104
105		# ALWAYS use expected information (for now)
106	!	I22.inv <- try(
107	!	lavTech(object, paste("inverted.information",
108	!	information,
109	!	sep = "."
110		)),
111	!	silent = TRUE
112		)
113		# just in case...
114	!	if (inherits(I22.inv, "try-error")) {
115	!	lav_msg_stop(gettext(
116	!	"could not compute modification indices; information matrix is singular"))
117		}
118
119	!	V <- I11 - I12 %% I22.inv %% I21
120	!	V.diag <- diag(V)
121		# dirty hack: catch very small or negative values in diag(V)
122		# this is needed eg when parameters are not identified if freed-up;
123	!	idx <- which(V.diag < .Machine$double.eps^(1 / 3)) # was 1/2 <0.6-14
124	!	if (length(idx) > 0L) {
125	!	V.diag[idx] <- as.numeric(NA)
126		}
127
128		# create and fill in mi
129	!	if (object@Data@nlevels == 1L) {
130	!	N <- object@SampleStats@ntotal
131		#if (object@Model@estimator %in% ("ML")) {
132	!	score <- -1 * score # due to gradient.logl
133		#}
134		} else {
135		# total number of clusters (over groups)
136	!	N <- 0
137	!	for (g in 1:object@SampleStats@ngroups) {
138	!	N <- N + object@Data@Lp[[g]]$nclusters[[2]]
139		}
140		# score <- score * (2 * object@SampleStats@ntotal) / N
141	!	score <- score / 2 # -2 * LRT
142		}
143	!	mi <- numeric(length(score))
144	!	mi[extra.idx] <- N * (score[extra.idx] * score[extra.idx]) / V.diag
145	!	if (length(model.idx) > 0L) {
146	!	mi[model.idx] <- N * (score[model.idx] * score[model.idx]) / diag(I22)
147		}
148
149	!	LIST$mi <- rep(as.numeric(NA), length(LIST$lhs))
150	!	LIST$mi[LIST$free > 0] <- mi
151
152		# handle equality constraints (if any)
153		# eq.idx <- which(LIST$op == "==")
154		# if(length(eq.idx) > 0L) {
155		# OUT <- lavTestScore(object, warn = FALSE)
156		# LIST$mi[ eq.idx ] <- OUT$uni$X2
157		# }
158
159		# scaled?
160		# if(length(object@test) > 1L) {
161		# LIST$mi.scaled <- LIST$mi / object@test[[2]]$scaling.factor
162		# }
163
164		# EPC
165	!	d <- (-1 * N) * score
166		# needed? probably not; just in case
167	!	d[which(abs(d) < 1e-15)] <- 1.0
168	!	LIST$epc[LIST$free > 0] <- mi / d
169
170
171		# standardize?
172	!	if (standardized) {
173	!	EPC <- LIST$epc
174
175	!	if (cov.std) {
176		# replace epc values for variances by est values
177	!	var.idx <- which(LIST$op == "~~" & LIST$lhs == LIST$rhs &
178	!	LIST$exo == 0L)
179	!	EPC[var.idx] <- LIST$est[var.idx]
180		}
181
182		# two problems:
183		# - EPC of variances can be negative, and that is
184		# perfectly legal
185		# - EPC (of variances) can be tiny (near-zero), and we should
186		# not divide by tiny variables
187	!	small.idx <- which(LIST$op == "~~" &
188	!	LIST$lhs == LIST$rhs &
189	!	abs(EPC) < sqrt(.Machine$double.eps))
190	!	if (length(small.idx) > 0L) {
191	!	EPC[small.idx] <- as.numeric(NA)
192		}
193
194		# get the sign
195	!	EPC.sign <- sign(LIST$epc)
196
197	!	LIST$sepc.lv <- EPC.sign * lav_standardize_lv(object,
198	!	partable = LIST,
199	!	est = abs(EPC),
200	!	cov.std = cov.std
201		)
202	!	if (length(small.idx) > 0L) {
203	!	LIST$sepc.lv[small.idx] <- 0
204		}
205	!	LIST$sepc.all <- EPC.sign * lav_standardize_all(object,
206	!	partable = LIST,
207	!	est = abs(EPC),
208	!	cov.std = cov.std
209		)
210	!	if (length(small.idx) > 0L) {
211	!	LIST$sepc.all[small.idx] <- 0
212		}
213	!	LIST$sepc.nox <- EPC.sign * lav_standardize_all_nox(object,
214	!	partable = LIST,
215	!	est = abs(EPC),
216	!	cov.std = cov.std
217		)
218	!	if (length(small.idx) > 0L) {
219	!	LIST$sepc.nox[small.idx] <- 0
220		}
221		}
222
223		# power?
224	!	if (power) {
225	!	LIST$delta <- delta
226		# FIXME: this is using epc in unstandardized metric
227		# this would be much more useful in standardized metric
228		# we need a lav_standardize_all.reverse function...
229	!	LIST$ncp <- (LIST$mi / (LIST$epc * LIST$epc)) * (delta * delta)
230	!	LIST$power <- 1 - pchisq(qchisq((1.0 - alpha), df = 1),
231	!	df = 1, ncp = LIST$ncp
232		)
233	!	LIST$decision <- character(length(LIST$power))
234
235		# five possibilities (Table 6 in Saris, Satorra, van der Veld, 2009)
236	!	mi.significant <- ifelse(1 - pchisq(LIST$mi, df = 1) < alpha,
237	!	TRUE, FALSE
238		)
239	!	high.power <- LIST$power > high.power
240		# FIXME: sepc.all or epc??
241		# epc.high <- abs(LIST$sepc.all) > LIST$delta
242	!	epc.high <- abs(LIST$epc) > LIST$delta
243
244	!	LIST$decision[which(!mi.significant & !high.power)] <- "(i)"
245	!	LIST$decision[which(mi.significant & !high.power)] <- "(m)"
246	!	LIST$decision[which(!mi.significant & high.power)] <- "(nm)"
247	!	LIST$decision[which(mi.significant & high.power &
248	!	!epc.high)] <- "epc:nm"
249	!	LIST$decision[which(mi.significant & high.power &
250	!	epc.high)] <- "epc:m"
251
252		# LIST$decision[ which(mi.significant & high.power) ] <- "epc"
253		# LIST$decision[ which(mi.significant & !high.power) ] <- "***"
254		# LIST$decision[ which(!mi.significant & !high.power) ] <- "(i)"
255		}
256
257		# remove rows corresponding to 'fixed.x' exogenous parameters
258		# exo.idx <- which(LIST$exo == 1L & nchar(LIST$plabel) > 0L)
259		# if(length(exo.idx) > 0L) {
260		# LIST <- LIST[-exo.idx,]
261		# }
262
263		# remove some columns
264	!	LIST$id <- LIST$ustart <- LIST$exo <- LIST$label <- LIST$plabel <- NULL
265	!	LIST$start <- LIST$free <- LIST$est <- LIST$se <- LIST$prior <- NULL
266	!	LIST$upper <- LIST$lower <- NULL
267
268	!	if (power) {
269	!	LIST$sepc.lv <- LIST$sepc.nox <- NULL
270		}
271
272		# create data.frame
273	!	LIST <- as.data.frame(LIST, stringsAsFactors = FALSE)
274	!	class(LIST) <- c("lavaan.data.frame", "data.frame")
275
276		# remove rows corresponding to 'old' free parameters
277	!	if (free.remove) {
278	!	old.idx <- which(LIST$user != 10L)
279	!	if (length(old.idx) > 0L) {
280	!	LIST <- LIST[-old.idx, ]
281		}
282		}
283
284		# remove rows corresponding to 'equality' constraints
285	!	eq.idx <- which(LIST$op == "==")
286	!	if (length(eq.idx) > 0L) {
287	!	LIST <- LIST[-eq.idx, ]
288		}
289
290		# remove even more columns
291	!	LIST$user <- NULL
292
293		# remove block/group/level is only single block
294	!	if (lav_partable_nblocks(LIST) == 1L) {
295	!	LIST$block <- NULL
296	!	LIST$group <- NULL
297	!	LIST$level <- NULL
298		}
299
300		# sort?
301	!	if (sort.) {
302	!	LIST <- LIST[order(LIST$mi, decreasing = TRUE), ]
303		}
304	!	if (minimum.value > 0.0) {
305	!	LIST <- LIST[!is.na(LIST$mi) & LIST$mi > minimum.value, ]
306		}
307	!	if (maximum.number < nrow(LIST)) {
308	!	LIST <- LIST[seq_len(maximum.number), ]
309		}
310	!	if (na.remove) {
311	!	idx <- which(is.na(LIST$mi))
312	!	if (length(idx) > 0) {
313	!	LIST <- LIST[-idx, ]
314		}
315		}
316	!	if (!is.null(op)) {
317	!	idx <- LIST$op %in% op
318	!	if (length(idx) > 0) {
319	!	LIST <- LIST[idx, ]
320		}
321		}
322
323		# add header
324		# TODO: small explanation of the columns in the header?
325		# attr(LIST, "header") <-
326		# c("modification indices for newly added parameters only; to\n",
327		# "see the effects of releasing equality constraints, use the\n",
328		# "lavTestScore() function")
329
330	!	LIST
331		}
332
333		# aliases
334		modificationIndices <- modificationindices <- modindices

1		lav_lavaan_step11_estoptim <- function(lavdata = NULL, # nolint
2		lavmodel = NULL,
3		lavcache = NULL,
4		lavsamplestats = NULL,
5		lavh1 = NULL,
6		lavoptions = NULL,
7		lavpartable = NULL) {
8		# # # # # # # # # # # # # #
9		# # 11. est + lavoptim # #
10		# # # # # # # # # # # # # #
11
12		# if lavoptions$do.fit and lavoptions$estimator not "none" and
13		# lavmodel$nx.free > 0
14		# select case lavoptions$optim.method
15		# case "noniter"
16		# try x <- lav_optim_noniter(...)
17		# case "em"
18		# if nlevels < 2L * error *
19		# try x <- lav_mvnorm_cluster_em_h0(...)
20		# case "gn"
21		# try x <- lav_optim_gn(...)
22		# case else
23		# set 1 in lavoptions$optim.attempts is it wasn't specified
24		# try x <- lav_model_estimate(...)
25		# if not successfull and optim.attempts > 1L
26		# try x <- lav_optim_estimate(...) with
27		# options$optim.parscale = "standardized"
28		# if not successfull and optim.attempts > 2L
29		# try x <- lav_optim_estimate(...) with start = "simple"
30		# if not successfull and optim.attempts > 3L
31		# try x <- lav_optim_estimate(...) with
32		# options$optim.parscale = "standardized" and start = "simple"
33		# end select
34		# if x not succesfully computed
35		# warning
36		# set starting values and appropriate attributes in x
37		# in case of non-linear constraints: store final con.jac and
38		# con.lambda in lavmodel
39		# store parameters in lavmodel
40		# store parameters in partable$est
41		# else
42		# initialize x and attributes (iterations, converged, warn.txt,
43		# control, dx) of x
44		# try fx <- lav_model_objective
45		# if not successfull
46		# fx = NA_real_
47		# attribute fx.group of fx = NA_real_
48		# store fx in attribute "fx" of x
49		# set lavpartable$est to starting values
50		# if lavoptions$optim.force.converged set attribute converged of x to TRUE
51		# store optimization info in lavoptim
52
53	140x	x <- NULL
54	140x	if (lavoptions$do.fit && lavoptions$estimator != "none" &&
55	140x	lavmodel@nx.free > 0L) {
56	138x	if (lav_verbose()) {
57	!	cat("lavoptim ... start:\n")
58		}
59
60		# non-iterative methods (fabin, miiv, ...)
61	138x	if (lavoptions$optim.method == "noniter") {
62	!	x <- try(
63	!	lav_optim_noniter(
64	!	lavmodel = lavmodel,
65	!	lavsamplestats = lavsamplestats,
66	!	lavh1 = lavh1,
67	!	lavdata = lavdata,
68	!	lavpartable = lavpartable,
69	!	lavoptions = lavoptions
70		),
71	!	silent = FALSE
72		)
73		# EM for multilevel models
74	138x	} else if (lavoptions$optim.method == "em") {
75		# multilevel only for now
76	!	stopifnot(lavdata@nlevels > 1L)
77	!	x <- try(
78	!	lav_mvnorm_cluster_em_h0(
79	!	lavsamplestats = lavsamplestats,
80	!	lavdata = lavdata,
81	!	lavimplied = NULL,
82	!	lavpartable = lavpartable,
83	!	lavmodel = lavmodel,
84	!	lavoptions = lavoptions,
85	!	fx.tol = lavoptions$em.fx.tol,
86	!	dx.tol = lavoptions$em.dx.tol,
87	!	max.iter = lavoptions$em.iter.max
88		),
89	!	silent = TRUE
90		)
91		# Gauss-Newton
92	138x	} else if (lavoptions$optim.method == "gn") {
93		# only tested for DLS (for now)
94	!	x <- try(
95	!	lav_optim_gn(
96	!	lavmodel = lavmodel,
97	!	lavsamplestats = lavsamplestats,
98	!	lavdata = lavdata,
99	!	lavpartable = lavpartable,
100	!	lavoptions = lavoptions
101		),
102	!	silent = TRUE
103		)
104
105		# Quasi-Newton
106		} else {
107		# for backwards compatibility (<0.6)
108	138x	if (is.null(lavoptions$optim.attempts)) {
109	!	lavoptions$optim.attempts <- 1L
110		}
111
112		# try 1
113	138x	if (lav_verbose()) {
114	!	cat("attempt 1 -- default options\n")
115		}
116	138x	x <- try(
117	138x	lav_model_estimate(
118	138x	lavmodel = lavmodel,
119	138x	lavpartable = lavpartable,
120	138x	lavsamplestats = lavsamplestats,
121	138x	lavdata = lavdata,
122	138x	lavoptions = lavoptions,
123	138x	lavcache = lavcache
124		),
125	138x	silent = TRUE
126		)
127
128		# try 2: optim.parscale = "standardize" (new in 0.6-7)
129	138x	if (lavoptions$optim.attempts > 1L &&
130	138x	lavoptions$rstarts == 0L &&
131	138x	(inherits(x, "try-error") \|\| !attr(x, "converged"))) {
132	2x	lavoptions2 <- lavoptions
133	2x	lavoptions2$optim.parscale <- "standardized"
134	2x	if (lav_verbose()) {
135	!	str(x)
136	!	cat("attempt 2 -- optim.parscale = \"standardized\"\n")
137		}
138	2x	x <- try(
139	2x	lav_model_estimate(
140	2x	lavmodel = lavmodel,
141	2x	lavpartable = lavpartable,
142	2x	lavsamplestats = lavsamplestats,
143	2x	lavdata = lavdata,
144	2x	lavoptions = lavoptions2,
145	2x	lavcache = lavcache
146		),
147	2x	silent = TRUE
148		)
149		}
150
151		# try 3: start = "simple"
152	138x	if (lavoptions$optim.attempts > 2L &&
153	138x	lavoptions$rstarts == 0L &&
154	138x	(inherits(x, "try-error") \|\| !attr(x, "converged"))) {
155	2x	if (lav_verbose()) {
156	!	str(x)
157	!	cat("attempt 3 -- start = \"simple\"\n")
158		}
159	2x	x <- try(
160	2x	lav_model_estimate(
161	2x	lavmodel = lavmodel,
162	2x	lavpartable = lavpartable,
163	2x	lavsamplestats = lavsamplestats,
164	2x	lavdata = lavdata,
165	2x	lavoptions = lavoptions,
166	2x	start = "simple",
167	2x	lavcache = lavcache
168		),
169	2x	silent = TRUE
170		)
171		}
172
173		# try 4: start = "simple" + optim.parscale = "standardize"
174	138x	if (lavoptions$optim.attempts > 3L &&
175	138x	lavoptions$rstarts == 0L &&
176	138x	(inherits(x, "try-error") \|\| !attr(x, "converged"))) {
177	!	lavoptions2 <- lavoptions
178	!	lavoptions2$optim.parscale <- "standardized"
179	!	if (lav_verbose()) {
180	!	str(x)
181	!	cat(
182	!	"attempt 4 -- optim.parscale = \"standardized\" + ",
183	!	"start = \"simple\"\n"
184		)
185		}
186	!	x <- try(
187	!	lav_model_estimate(
188	!	lavmodel = lavmodel,
189	!	lavpartable = lavpartable,
190	!	lavsamplestats = lavsamplestats,
191	!	lavdata = lavdata,
192	!	lavoptions = lavoptions2,
193	!	start = "simple",
194	!	lavcache = lavcache
195		),
196	!	silent = TRUE
197		)
198		}
199
200
201		# random starts? -- new in 0.6-18
202		# run this even if we already have a converged solution
203		# perhaps we find a better solution?
204	138x	if (lavoptions$rstarts > 0L) {
205	!	x.rstarts <- vector("list", length = lavoptions$rstarts)
206	!	if (lav_verbose()) {
207	!	str(x)
208	!	cat("trying again with random starts (", lavoptions$rstarts,
209	!	" in total):\n",
210	!	sep = ""
211		)
212		}
213	!	for (i in seq_len(lavoptions$rstarts)) {
214	!	if (lav_verbose()) {
215	!	cat("-- random start run: ", i, "\n")
216		}
217	!	x.rstarts[[i]] <-
218	!	try(
219	!	lav_model_estimate(
220	!	lavmodel = lavmodel,
221	!	lavpartable = lavpartable,
222	!	lavsamplestats = lavsamplestats,
223	!	lavdata = lavdata,
224	!	lavoptions = lavoptions,
225	!	start = "random",
226	!	lavcache = lavcache
227		),
228	!	silent = TRUE
229		)
230		}
231
232		# pick best solution (if any)
233	!	x.converged <- vector("list", length = 0L)
234	!	fx.rstarts <- numeric(0L)
235	!	ok.flag <- sapply(x.rstarts, function(x) {
236	!	if (inherits(x, "try-error")) {
237	!	return(FALSE)
238		} else {
239	!	return(attr(x, "converged"))
240		}
241		})
242	!	if (sum(ok.flag) > 0L) {
243	!	x.converged <- x.rstarts[ok.flag]
244		}
245	!	if (length(x.converged) > 0L) {
246	!	fx.rstarts <- sapply(x.converged, "attr", "fx")
247	!	x.best <- x.converged[[which.min(fx.rstarts)]]
248	!	fx.best <- attr(x.best, "fx")[1]
249
250		# if we did not find a converged solution, use x.best
251	!	if (inherits(x, "try-error") \|\| !attr(x, "converged")) {
252	!	x <- x.best
253
254
255		# if we already had a converged solution, only replace
256		# if fx.best is better than attr(x, "fx")[1]
257		} else {
258	!	if (fx.best < attr(x, "fx")[1]) {
259	!	x <- x.best
260		}
261		}
262		}
263
264	!	attr(x, "x.rstarts") <- x.rstarts
265		} # random starts
266		}
267
268		# optimization failed with error
269	138x	if (inherits(x, "try-error")) {
270	!	warn.txt <- gettext("Model estimation FAILED! Returning starting values.")
271	!	x <- lav_model_get_parameters(
272	!	lavmodel = lavmodel,
273	!	type = "free"
274	!	) # starting values
275	!	attr(x, "iterations") <- 0L
276	!	attr(x, "converged") <- FALSE
277	!	attr(x, "warn.txt") <- warn.txt
278	!	attr(x, "control") <- lavoptions$control
279	!	attr(x, "dx") <- numeric(0L)
280	!	fx <- as.numeric(NA)
281	!	attr(fx, "fx.group") <- as.numeric(NA)
282	!	attr(x, "fx") <- fx
283		}
284
285		# if a warning was produced, say it here
286	138x	warn.txt <- attr(x, "warn.txt")
287	138x	if (!is.null(warn.txt) && nchar(warn.txt) > 0L) {
288	!	lav_msg_warn(gettext(warn.txt))
289		}
290
291		# in case of non-linear constraints: store final con.jac and con.lambda
292		# in lavmodel
293	138x	if (!is.null(attr(x, "con.jac"))) {
294	65x	lavmodel@con.jac <- attr(x, "con.jac")
295		}
296	138x	if (!is.null(attr(x, "con.lambda"))) {
297	65x	lavmodel@con.lambda <- attr(x, "con.lambda")
298		}
299
300		# store parameters in lavmodel
301	138x	lavmodel <- lav_model_set_parameters(lavmodel, x = as.numeric(x))
302
303		# store parameters in @ParTable$est
304	138x	lavpartable$est <- lav_model_get_parameters(
305	138x	lavmodel = lavmodel,
306	138x	type = "user", extra = TRUE
307		)
308
309	138x	if (lav_verbose()) {
310	!	cat("lavoptim ... done.\n")
311		}
312		} else {
313	2x	x <- numeric(0L)
314	2x	attr(x, "iterations") <- 0L
315	2x	attr(x, "converged") <- FALSE
316	2x	attr(x, "warn.txt") <- ""
317	2x	attr(x, "control") <- lavoptions$control
318	2x	attr(x, "dx") <- numeric(0L)
319	2x	fx <- try(lav_model_objective(
320	2x	lavmodel = lavmodel,
321	2x	lavsamplestats = lavsamplestats, lavdata = lavdata,
322	2x	lavcache = lavcache
323	2x	), silent = TRUE)
324	2x	if (!inherits(fx, "try-error")) {
325	2x	attr(x, "fx") <- fx
326		} else {
327	!	fx <- as.numeric(NA)
328	!	attr(fx, "fx.group") <- as.numeric(NA)
329	!	attr(x, "fx") <- fx
330		}
331
332	2x	lavpartable$est <- lavpartable$start
333		}
334
335		# should we fake/force convergence? (eg. to enforce the
336		# computation of a test statistic)
337	140x	if (lavoptions$optim.force.converged) {
338	!	attr(x, "converged") <- TRUE
339		}
340
341		# store optimization info in lavoptim
342	140x	lavoptim <- list()
343	140x	x2 <- x
344	140x	attributes(x2) <- NULL
345	140x	lavoptim$x <- x2
346	140x	lavoptim$dx <- attr(x, "dx")
347	140x	lavoptim$npar <- length(x)
348	140x	lavoptim$iterations <- attr(x, "iterations")
349	140x	lavoptim$converged <- attr(x, "converged")
350	140x	lavoptim$warn.txt <- attr(x, "warn.txt")
351	140x	lavoptim$parscale <- attr(x, "parscale")
352	140x	lavoptim$partrace <- attr(x, "partrace")
353	140x	fx.copy <- fx <- attr(x, "fx")
354	140x	attributes(fx) <- NULL
355	140x	lavoptim$fx <- fx
356	140x	lavoptim$fx.group <- attr(fx.copy, "fx.group")
357	140x	if (!is.null(attr(fx.copy, "logl.group"))) {
358	!	lavoptim$logl.group <- attr(fx.copy, "logl.group")
359	!	lavoptim$logl <- sum(lavoptim$logl.group)
360		} else {
361	140x	lavoptim$logl.group <- as.numeric(NA)
362	140x	lavoptim$logl <- as.numeric(NA)
363		}
364	140x	lavoptim$control <- attr(x, "control")
365	140x	if (!is.null(attr(x, "x.rstarts"))) {
366	!	lavoptim$x.rstarts <- attr(x, "x.rstarts")
367		}
368
369	140x	lavpartable <- lav_partable_set_cache(lavpartable, force = TRUE)
370	140x	list(
371	140x	lavoptim = lavoptim, lavmodel = lavmodel, lavpartable = lavpartable,
372	140x	x = x
373		)
374		}

1		# get missing patterns
2		lav_data_missing_patterns <- function(Y, sort.freq = FALSE, coverage = FALSE,
3		Lp = NULL) {
4		# handle two-level data
5	10x	if (!is.null(Lp)) {
6	!	Y.orig <- Y
7	!	Z <- NULL
8	!	if (length(Lp$between.idx[[2]]) > 0L) {
9	!	Y <- Y[, -Lp$between.idx[[2]], drop = FALSE]
10	!	z.idx <- which(!duplicated(Lp$cluster.idx[[2]]))
11	!	Z <- Y.orig[z.idx, Lp$between.idx[[2]], drop = FALSE]
12		}
13		}
14
15		# construct TRUE/FALSE matrix: TRUE if value is observed
16	10x	OBS <- !is.na(Y)
17
18		# empty cases
19	10x	empty.idx <- which(rowSums(OBS) == 0L)
20
21		# pattern of observed values per observation
22	10x	case.id <- apply(1L * OBS, 1L, paste, collapse = "")
23
24		# remove empty patterns
25	10x	if (length(empty.idx)) {
26	!	case.id.nonempty <- case.id[-empty.idx]
27		} else {
28	10x	case.id.nonempty <- case.id
29		}
30
31		# sort non-empty patterns (from high occurence to low occurence)
32	10x	if (sort.freq) {
33	10x	TABLE <- sort(table(case.id.nonempty), decreasing = TRUE)
34		} else {
35	!	TABLE <- table(case.id.nonempty)
36		}
37
38		# unique pattern ids
39	10x	pat.id <- names(TABLE)
40
41		# number of patterns
42	10x	pat.npatterns <- length(pat.id)
43
44		# case idx per pattern
45	10x	pat.case.idx <- lapply(
46	10x	seq_len(pat.npatterns),
47	10x	function(p) which(case.id == pat.id[p])
48		)
49
50		# unique pattern frequencies
51	10x	pat.freq <- as.integer(TABLE)
52
53		# first occurrence of each pattern
54	10x	pat.first <- match(pat.id, case.id)
55
56		# TRUE/FALSE for each pattern
57	10x	pat.obs <- OBS[pat.first, , drop = FALSE] # observed per pattern
58
59	10x	Mp <- list(
60	10x	npatterns = pat.npatterns, id = pat.id, freq = pat.freq,
61	10x	case.idx = pat.case.idx, pat = pat.obs, empty.idx = empty.idx,
62	10x	nel = sum(OBS)
63		)
64
65	10x	if (coverage) {
66		# FIXME: if we have empty cases, include them in N?
67		# no for now
68	10x	Mp$coverage <- crossprod(OBS) / sum(pat.freq)
69		# Mp$coverage <- crossprod(OBS) / NROW(Y)
70		}
71
72		# additional info in we have two-level data
73	10x	if (!is.null(Lp)) {
74	!	Mp$j.idx <- lapply(
75	!	seq_len(pat.npatterns),
76	!	function(p) Lp$cluster.idx[[2]][Mp$case.idx[[p]]]
77		)
78	!	Mp$j1.idx <- lapply(
79	!	seq_len(pat.npatterns),
80	!	function(p) sort(unique.default(Mp$j.idx[[p]])) # new in 0.6-19: sort!!
81		# because table/tabulate
82		# also sorts...
83		)
84	!	Mp$j.freq <- lapply(
85	!	seq_len(pat.npatterns),
86	!	function(p) as.integer(unname(table(sort(Mp$j.idx[[p]])))) # sort not needed?
87		)
88
89		# between-level patterns
90	!	if (!is.null(Z)) {
91	!	Mp$Zp <- lav_data_missing_patterns(Z,
92	!	sort.freq = FALSE,
93	!	coverage = FALSE, Lp = NULL
94		)
95		}
96		}
97
98	10x	Mp
99		}
100
101		# get response patterns (ignore empty cases!)
102		lav_data_resp_patterns <- function(Y) {
103		# construct TRUE/FALSE matrix: TRUE if value is observed
104	2x	OBS <- !is.na(Y)
105
106		# empty cases
107	2x	empty.idx <- which(rowSums(OBS) == 0L)
108
109		# removeYempty cases
110	2x	if (length(empty.idx) > 0L) {
111	!	Y <- Y[-empty.idx, , drop = FALSE]
112		}
113
114	2x	ntotal <- nrow(Y)
115	2x	nvar <- ncol(Y)
116
117		# identify, label and sort response patterns
118	2x	id <- apply(Y, MARGIN = 1, paste, collapse = "")
119
120		# sort patterns (from high occurence to low occurence)
121	2x	TABLE <- sort(table(id), decreasing = TRUE)
122	2x	order <- names(TABLE)
123	2x	npatterns <- length(TABLE)
124	2x	pat <- Y[match(order, id), , drop = FALSE]
125	2x	row.names(pat) <- as.character(TABLE)
126
127		# handle NA?
128	2x	Y[is.na(Y)] <- -9
129	2x	total.patterns <- prod(apply(Y, 2, function(x) length(unique(x))))
130	2x	empty.patterns <- total.patterns - npatterns
131		# return a list
132		# out <- list(nobs=ntotal, nvar=nvar,
133		# id=id, npatterns=npatterns,
134		# order=order, pat=pat)
135
136		# only return pat
137	2x	out <- list(
138	2x	npatterns = npatterns, pat = pat, total.patterns = total.patterns,
139	2x	empty.patterns = empty.patterns
140		)
141
142	2x	out
143		}
144
145		# get cluster information
146		# - cluster can be a vector!
147		# - clus can contain multiple columns!
148		lav_data_cluster_patterns <- function(Y = NULL,
149		clus = NULL, # the cluster ids
150		cluster = NULL, # the cluster 'names'
151		multilevel = FALSE,
152		ov.names = NULL,
153		ov.names.x = NULL,
154		ov.names.l = NULL) {
155		# how many levels?
156	4x	nlevels <- length(cluster) + 1L
157
158		# did we get any data (or is this just for lav_data_simulate_old)
159	4x	if (!is.null(Y) && !is.null(clus)) {
160	4x	haveData <- TRUE
161		} else {
162	!	haveData <- FALSE
163		}
164
165		# check clus
166	4x	if (haveData) {
167	4x	stopifnot(ncol(clus) == (nlevels - 1L), nrow(Y) == nrow(clus))
168		}
169
170	4x	cluster.size <- vector("list", length = nlevels)
171	4x	cluster.id <- vector("list", length = nlevels)
172	4x	cluster.idx <- vector("list", length = nlevels)
173	4x	nclusters <- vector("list", length = nlevels)
174	4x	cluster.sizes <- vector("list", length = nlevels)
175	4x	ncluster.sizes <- vector("list", length = nlevels)
176	4x	cluster.size.ns <- vector("list", length = nlevels)
177
178	4x	ov.idx <- vector("list", length = nlevels)
179	4x	ov.x.idx <- vector("list", length = nlevels)
180	4x	ov.y.idx <- vector("list", length = nlevels)
181	4x	both.idx <- vector("list", length = nlevels)
182	4x	within.idx <- vector("list", length = nlevels)
183	4x	within.x.idx <- vector("list", length = nlevels)
184	4x	within.y.idx <- vector("list", length = nlevels)
185	4x	between.idx <- vector("list", length = nlevels)
186	4x	between.x.idx <- vector("list", length = nlevels)
187	4x	between.y.idx <- vector("list", length = nlevels)
188	4x	both.names <- vector("list", length = nlevels)
189	4x	within.names <- vector("list", length = nlevels)
190	4x	within.x.names <- vector("list", length = nlevels)
191	4x	within.y.names <- vector("list", length = nlevels)
192	4x	between.names <- vector("list", length = nlevels)
193	4x	between.x.names <- vector("list", length = nlevels)
194	4x	between.y.names <- vector("list", length = nlevels)
195
196		# level-1 is special
197	4x	if (haveData) {
198	4x	nclusters[[1]] <- NROW(Y)
199		}
200
201		# higher levels:
202	4x	for (l in 2:nlevels) {
203	4x	if (haveData) {
204	4x	CLUS <- clus[, (l - 1L)]
205
206		# cluster.id: original cluster identifier
207	4x	cluster.id[[l]] <- unique(CLUS)
208
209		# cluster.idx: internal cluster idx (always an integer from 1 to J
210		# for every obervation;
211		# the first cluster id we observe is '1', the second '2', etc...)
212	4x	cluster.idx[[l]] <- match(CLUS, cluster.id[[l]])
213
214	4x	cluster.size[[l]] <- tabulate(cluster.idx[[l]])
215	4x	nclusters[[l]] <- length(cluster.size[[l]])
216		# check if we have more observations than clusters
217	4x	if (nclusters[[1]] == nclusters[[l]]) {
218	!	lav_msg_stop(gettext("every cluster contains only one observation."))
219		}
220	4x	mean.cluster.size <- mean(cluster.size[[l]])
221	4x	if (mean.cluster.size < 1.5) {
222	!	lav_msg_warn(gettextf(
223	!	"mean cluster size is %s. This means that many clusters only
224	!	contain a single observation.", mean.cluster.size))
225		}
226	4x	cluster.sizes[[l]] <- unique(cluster.size[[l]])
227	4x	ncluster.sizes[[l]] <- length(cluster.sizes[[l]])
228	4x	cluster.size.ns[[l]] <- as.integer(table(factor(cluster.size[[l]],
229	4x	levels = as.character(cluster.sizes[[l]])
230		)))
231		} else {
232	!	cluster.id[[l]] <- integer(0L)
233	!	cluster.idx[[l]] <- integer(0L)
234	!	cluster.size[[l]] <- integer(0L)
235	!	nclusters[[l]] <- integer(0L)
236	!	cluster.sizes[[l]] <- integer(0L)
237	!	ncluster.sizes[[l]] <- integer(0L)
238	!	cluster.size.ns[[l]] <- integer(0L)
239		}
240		}
241
242		# for all levels:
243	4x	if (multilevel) {
244	4x	for (l in 1:nlevels) {
245		# index of ov.names for this level
246	8x	ov.idx[[l]] <- match(ov.names.l[[l]], ov.names)
247
248		# new in 0.6-12: always preserve the order of ov.idx[[l]]
249	8x	idx <- which(ov.names %in% ov.names.l[[1]] &
250	8x	ov.names %in% ov.names.l[[2]])
251	8x	both.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]
252
253	8x	idx <- which(ov.names %in% ov.names.l[[1]] &
254	8x	!ov.names %in% ov.names.l[[2]])
255	8x	within.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]
256		# backwards compatibility: also store in within.idx[[2]]
257	8x	if (l == 2) {
258	4x	within.idx[[l]] <- within.idx[[1]]
259		}
260
261	8x	idx <- which(!ov.names %in% ov.names.l[[1]] &
262	8x	ov.names %in% ov.names.l[[2]])
263	8x	between.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]
264
265		# names
266		# both.names[[l]] <- ov.names[ ov.names %in% ov.names.l[[1]] &
267		# ov.names %in% ov.names.l[[2]] ]
268		# within.names[[l]] <- ov.names[ ov.names %in% ov.names.l[[1]] &
269		# !ov.names %in% ov.names.l[[2]] ]
270		# between.names[[l]] <- ov.names[!ov.names %in% ov.names.l[[1]] &
271		# ov.names %in% ov.names.l[[2]] ]
272	8x	both.names[[l]] <- ov.names[both.idx[[l]]]
273	8x	within.names[[l]] <- ov.names[within.idx[[l]]]
274	8x	between.names[[l]] <- ov.names[between.idx[[l]]]
275		}
276		}
277
278		# fixed.x wrt variable index
279	4x	if (multilevel && length(ov.names.x) > 0L) {
280	!	for (l in 1:nlevels) {
281		# some ov.names.x could be 'splitted', and end up in both.names
282		# they should NOT be part ov.x.idx (as they become latent variables)
283	!	idx <- which(ov.names %in% ov.names.x &
284	!	ov.names %in% ov.names.l[[l]] &
285	!	!ov.names %in% unlist(both.names))
286	!	ov.x.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]
287
288		# not any longer, we split them, but still treat them as 'fixed'
289		# ov.x.idx[[l]] <- which( ov.names %in% ov.names.x &
290		# ov.names %in% ov.names.l[[l]] )
291
292		# if some ov.names.x have been 'splitted', and end up in both.names,
293		# they should become part of ov.y.idx (despite being exogenous)
294		# as they are now latent variables
295	!	idx <- which(ov.names %in% ov.names.l[[l]] &
296	!	!ov.names %in% ov.names.x[!ov.names.x %in% unlist(both.names)])
297	!	ov.y.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]
298
299		# not any longer, ov.x stays ov.x (even if we split)
300		# ov.y.idx[[l]] <- which( ov.names %in% ov.names.l[[l]] &
301		# !ov.names %in% ov.names.x )
302
303
304		# if(l == 1L) {
305		# next
306		# }
307		# below, we only fill in the [[2]] element (and higher)
308
309	!	idx <- which(ov.names %in% ov.names.l[[1]] &
310	!	!ov.names %in% ov.names.l[[2]] &
311	!	ov.names %in% ov.names.x)
312	!	within.x.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]
313		# backwards compatibility: also store in within.x.idx[[2]]
314	!	if (l == 2) {
315	!	within.x.idx[[l]] <- within.x.idx[[1]]
316		}
317
318	!	idx <- which(ov.names %in% ov.names.l[[1]] &
319	!	!ov.names %in% ov.names.l[[2]] &
320	!	!ov.names %in% ov.names.x)
321	!	within.y.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]
322		# backwards compatibility: also store in within.y.idx[[2]]
323	!	if (l == 2) {
324	!	within.y.idx[[l]] <- within.y.idx[[1]]
325		}
326
327	!	idx <- which(!ov.names %in% ov.names.l[[1]] &
328	!	ov.names %in% ov.names.l[[2]] &
329	!	ov.names %in% ov.names.x)
330	!	between.x.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]
331
332	!	idx <- which(!ov.names %in% ov.names.l[[1]] &
333	!	ov.names %in% ov.names.l[[2]] &
334	!	!ov.names %in% ov.names.x)
335	!	between.y.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx]
336
337		# within.x.names[[l]] <- ov.names[ ov.names %in% ov.names.l[[1]] &
338		# ov.names %in% ov.names.x &
339		# !ov.names %in% ov.names.l[[2]] ]
340		# within.y.names[[l]] <- ov.names[ ov.names %in% ov.names.l[[1]] &
341		# !ov.names %in% ov.names.x &
342		# !ov.names %in% ov.names.l[[2]] ]
343		# between.x.names[[l]] <- ov.names[!ov.names %in% ov.names.l[[1]] &
344		# ov.names %in% ov.names.x &
345		# ov.names %in% ov.names.l[[2]] ]
346		# between.y.names[[l]] <- ov.names[!ov.names %in% ov.names.l[[1]] &
347		# !ov.names %in% ov.names.x &
348		# ov.names %in% ov.names.l[[2]] ]
349	!	within.x.names[[l]] <- ov.names[within.x.idx[[l]]]
350	!	within.y.names[[l]] <- ov.names[within.y.idx[[l]]]
351	!	between.x.names[[l]] <- ov.names[between.x.idx[[l]]]
352	!	between.y.names[[l]] <- ov.names[between.y.idx[[l]]]
353		}
354		} else {
355	4x	ov.y.idx <- ov.idx
356		}
357
358	4x	out <- list(
359	4x	ov.names = ov.names, ov.names.x = ov.names.x, # for this group
360	4x	cluster = cluster, # clus = clus,
361		# per level
362	4x	nclusters = nclusters,
363	4x	cluster.size = cluster.size, cluster.id = cluster.id,
364	4x	cluster.idx = cluster.idx, cluster.sizes = cluster.sizes,
365	4x	ncluster.sizes = ncluster.sizes,
366	4x	cluster.size.ns = cluster.size.ns,
367	4x	ov.idx = ov.idx, ov.x.idx = ov.x.idx, ov.y.idx = ov.y.idx,
368	4x	both.idx = both.idx, within.idx = within.idx,
369	4x	within.x.idx = within.x.idx, within.y.idx = within.y.idx,
370	4x	between.idx = between.idx,
371	4x	between.x.idx = between.x.idx, between.y.idx = between.y.idx,
372	4x	both.names = both.names, within.names = within.names,
373	4x	within.x.names = within.x.names,
374	4x	within.y.names = within.y.names,
375	4x	between.names = between.names,
376	4x	between.x.names = between.x.names,
377	4x	between.y.names = between.y.names
378		)
379
380	4x	out
381		}

1		lav_lavaan_step15_baseline <- function(lavoptions = NULL,
2		lavsamplestats = NULL,
3		lavdata = NULL,
4		lavcache = NULL,
5		lavh1 = NULL,
6		lavpartable = NULL) {
7		# # # # # # # # # # #
8		# # 15. baseline # # (since 0.6-5)
9		# # # # # # # # # # #
10
11		# if options$do.fit and options$test not "none" and options$baseline = TRUE
12		# try fit.indep <- lav_object_independence(...)
13		# if not succesfull or not converged
14		# warning
15		# lavbaseline < list()
16		# else
17		# lavbaseline <- list with partable and test of fit.indep
18	140x	lavbaseline <- list()
19	140x	if (lavoptions$do.fit &&
20	140x	!("none" %in% lavoptions$test) &&
21	140x	is.logical(lavoptions$baseline) && lavoptions$baseline) {
22	45x	if (lav_verbose()) {
23	!	cat("lavbaseline ...")
24		}
25	45x	current.verbose <- lav_verbose()
26	45x	lav_verbose(FALSE)
27	45x	fit.indep <- try(lav_object_independence(
28	45x	object = NULL,
29	45x	lavsamplestats = lavsamplestats,
30	45x	lavdata = lavdata,
31	45x	lavcache = lavcache,
32	45x	lavoptions = lavoptions,
33	45x	lavpartable = lavpartable,
34	45x	lavh1 = lavh1
35	45x	), silent = TRUE)
36	45x	lav_verbose(current.verbose)
37	45x	if (inherits(fit.indep, "try-error") \|\| !fit.indep@optim$converged) {
38	!	lav_msg_warn(gettext("estimation of the baseline model failed."))
39	!	lavbaseline <- list()
40	!	if (lav_verbose()) {
41	!	cat(" FAILED.\n")
42		}
43		} else {
44		# store relevant information
45	45x	lavbaseline <- list(
46	45x	partable = fit.indep@ParTable,
47	45x	test = fit.indep@test
48		)
49	45x	if (lav_verbose()) {
50	!	cat(" done.\n")
51		}
52		}
53		}
54
55	140x	lavbaseline
56		}

1		# Gauss-Newton style optimization
2		#
3		# Initial version needed for DLS - model based
4		# YR - 19 Jan 2021
5		#
6		# TODo:
7		# - what to do if the function value goes up?
8		# - handle general (nonlinear) equality constraints
9		# - handle general (nonlinear) inequality constraints
10		# - better approach for simple bounds
11		# ...
12
13		# YR - 04 Nov 2023: add huber = TRUE option to get 'outlier-robust' estimates
14		# (see Yuan and Zhong 2008, where they call this IRLS_r)
15
16
17		# objective function, plus 'extra' information
18		# needed for a Gauss Newton step
19		lav_objective_GN <- function(x, lavsamplestats = NULL, lavmodel = NULL,
20		lavoptions = NULL, lavdata = NULL,
21		extra = FALSE, lambda = NULL) {
22		# evaluate objective function
23	!	lavmodel <- lav_model_set_parameters(lavmodel = lavmodel, x = x)
24	!	obj <- lav_model_objective(
25	!	lavmodel = lavmodel, lavdata = lavdata,
26	!	lavsamplestats = lavsamplestats
27		)
28	!	attributes(obj) <- NULL
29
30		# monitoring obj only
31	!	if (!extra) {
32		# handle linear equality constraints
33	!	if (lavmodel@eq.constraints) {
34	!	hx <- lavmodel@ceq.function(x)
35	!	obj <- obj + max(abs(lambda)) * sum(abs(hx))
36		}
37	!	return(list(obj = obj, U.invQ = NULL, lambda = lambda))
38		}
39
40		# model implied statistics
41	!	lavimplied <- lav_model_implied(lavmodel = lavmodel)
42	!	wls.est <- lav_model_wls_est(lavmodel = lavmodel, lavimplied = lavimplied)
43
44		# observed statistics
45	!	wls.obs <- lavsamplestats@WLS.obs
46
47		# always use expected information
48	!	A1 <- lav_model_h1_information_expected(
49	!	lavobject = NULL,
50	!	lavmodel = lavmodel,
51	!	lavsamplestats = lavsamplestats,
52	!	lavdata = lavdata,
53	!	lavoptions = lavoptions,
54	!	lavimplied = lavimplied,
55	!	lavh1 = NULL,
56	!	lavcache = NULL
57		)
58		# Delta
59	!	Delta <- lav_model_delta(lavmodel = lavmodel)
60
61		# first group
62	!	g <- 1L
63	!	if (lavmodel@estimator == "DWLS") {
64	!	PRE.g <- t(Delta[[g]] * A1[[g]])
65		} else {
66	!	PRE.g <- t(Delta[[g]]) %*% A1[[g]]
67		}
68	!	Q.g <- PRE.g %*% (wls.obs[[g]] - wls.est[[g]])
69	!	U.g <- PRE.g %*% Delta[[g]]
70
71		# additional groups (if any)
72	!	if (lavsamplestats@ngroups > 1L) {
73	!	fg <- lavsamplestats@nobs[[1]] / lavsamplestats@ntotal
74	!	Q <- fg * Q.g
75	!	U <- fg * U.g
76
77	!	for (g in 2:lavsamplestats@ngroups) {
78	!	fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal
79	!	if (lavmodel@estimator == "DWLS") {
80	!	PRE.g <- t(Delta[[g]] * A1[[g]])
81		} else {
82	!	PRE.g <- t(Delta[[g]]) %*% A1[[g]]
83		}
84	!	Q.g <- PRE.g %*% (wls.obs[[g]] - wls.est[[g]])
85	!	U.g <- PRE.g %*% Delta[[g]]
86
87	!	Q <- Q + fg * Q.g
88	!	U <- U + fg * U.g
89		}
90		} else {
91	!	Q <- Q.g
92	!	U <- U.g
93		}
94
95		# handle equality constraints
96		# this can be made more efficient; see Jamshidian & Bentler 1993
97		# where instead of inverting a p+r matrix, they use a p-r matrix
98		# (if the eq constraints are linear)
99	!	if (lavmodel@eq.constraints) {
100	!	hx <- lavmodel@ceq.function(x)
101	!	npar <- nrow(U)
102	!	H <- lavmodel@con.jac
103	!	U <- U + crossprod(H)
104	!	U <- rbind(
105	!	cbind(U, t(H)),
106	!	cbind(H, matrix(0, nrow(H), nrow(H)))
107		)
108	!	Q <- rbind(Q, matrix(-hx, nrow(H), 1))
109		}
110
111		# compute step
112		# note, we could use U + k*I for a given scalar 'k' (Levenberg, 1944)
113		# or U + k*(diag(U) (Marquardt, 1963)
114	!	U.invQ <- drop(solve(U, Q))
115	!	if (lavmodel@eq.constraints) {
116		# merit function
117	!	lambda <- U.invQ[-seq_len(npar)]
118	!	obj <- obj + max(abs(lambda)) * sum(abs(hx))
119		} else {
120	!	lambda <- NULL
121		}
122
123	!	list(obj = obj, U.invQ = U.invQ, lambda = lambda)
124		}
125
126		lav_optim_gn <- function(lavmodel = NULL, lavsamplestats = NULL,
127		lavpartable = NULL,
128		lavdata = NULL, lavoptions = NULL) {
129		# no support (yet) for nonlinear constraints
130	!	nonlinear.idx <- c(
131	!	lavmodel@ceq.nonlinear.idx,
132	!	lavmodel@cin.nonlinear.idx
133		)
134	!	if (length(nonlinear.idx) > 0L) {
135	!	lav_msg_stop(gettext(
136	!	"nonlinear constraints not supported (yet) with optim.method = \"GN\"."))
137		}
138
139		# no support (yet) for inequality constraints
140	!	if (!is.null(body(lavmodel@cin.function))) {
141	!	lav_msg_stop(gettext(
142	!	"inequality constraints not supported (yet) with optim.method = \"GN\"."))
143		}
144
145		# extract current set of free parameters
146	!	x <- lav_model_get_parameters(lavmodel)
147	!	npar <- length(x)
148
149		# extract bounds (if any)
150	!	lb <- ub <- NULL
151	!	if (!is.null(lavpartable) && !is.null(lavpartable$lower)) {
152	!	lb <- lavpartable$lower[lavpartable$free > 0]
153	!	stopifnot(length(x) == length(lb))
154	!	lb.idx <- which(x < lb)
155	!	if (length(lb.idx) > 0L) {
156	!	x[lb.idx] <- lb[lb.idx]
157		}
158		}
159	!	if (!is.null(lavpartable) && !is.null(lavpartable$upper)) {
160	!	ub <- lavpartable$upper[lavpartable$free > 0]
161	!	stopifnot(length(x) == length(ub))
162	!	ub.idx <- which(x > ub)
163	!	if (length(ub.idx) > 0L) {
164	!	x[ub.idx] <- ub[ub.idx]
165		}
166		}
167
168		# options
169	!	iter.max <- lavoptions$optim.gn.iter.max
170	!	tol.x <- lavoptions$optim.gn.tol.x
171	!	stephalf.max <- as.integer(lavoptions$optim.gn.stephalf.max)
172	!	if (stephalf.max < 0L) {
173	!	stephalf.max <- 0L
174		}
175
176		# initialize
177	!	iter <- 0
178	!	alpha <- 1.0
179	!	old.x <- x
180
181		# start Gauss-Newton steps
182	!	for (iter in seq_len(iter.max)) {
183	!	old.out <- lav_objective_GN(
184	!	x = old.x, lavsamplestats = lavsamplestats,
185	!	lavoptions = lavoptions, lavdata = lavdata,
186	!	lavmodel = lavmodel, extra = TRUE
187		)
188	!	old.obj <- old.out$obj
189	!	U.invQ <- old.out$U.invQ
190
191		# only the first time
192	!	if (lav_verbose() && iter == 1L) {
193	!	cat("iteration = ", sprintf("%2d", iter - 1L),
194	!	": objective = ", sprintf("%11.9f", old.obj), "\n",
195	!	sep = ""
196		)
197		}
198
199		# update
200	!	alpha <- 1.0
201	!	step <- U.invQ[seq_len(npar)]
202		# TODO: if step-halving fails, we could also
203		# allow the steps to be negative
204	!	for (h in 1:max(1L, stephalf.max)) {
205	!	new.x <- old.x + (alpha * step)
206
207		# apply simple bounds (if any)
208	!	if (!is.null(lb)) {
209	!	lb.idx <- which(new.x < lb)
210	!	if (length(lb.idx) > 0L) {
211	!	new.x[lb.idx] <- lb[lb.idx]
212		}
213		}
214	!	if (!is.null(ub)) {
215	!	ub.idx <- which(new.x > ub)
216	!	if (length(ub.idx) > 0L) {
217	!	new.x[ub.idx] <- ub[ub.idx]
218		}
219		}
220
221	!	new.obj <- lav_objective_GN(
222	!	x = new.x,
223	!	lavsamplestats = lavsamplestats,
224	!	lavdata = lavdata, lavoptions = lavoptions,
225	!	lavmodel = lavmodel, extra = FALSE,
226	!	lambda = old.out$lambda
227	!	)$obj
228
229	!	if (is.finite(new.obj) && new.obj < old.obj) {
230	!	break
231	!	} else if (stephalf.max == 0L) { # no step-halving!
232	!	break
233		} else {
234		# step-halving
235	!	alpha <- alpha / 2.0
236		# if(verbose) {
237		# cat(" -- step halving -- : alpha = ", alpha, "\n")
238		# }
239		}
240		}
241
242		# TODO - if this fails, we need to recover somehow
243		# negative steps:
244	!	if (stephalf.max != 0L && h == stephalf.max) {
245	!	if (lav_verbose()) {
246	!	cat(" -- step halving failed; function value may increase.\n")
247		}
248		# forcing step with alpha = 1
249	!	new.x <- old.x + (1 * step)
250		}
251
252	!	rms.x <- sqrt(mean((old.x - new.x) * (old.x - new.x)))
253
254		# verbose?
255	!	if (lav_verbose()) {
256	!	cat("iteration = ", sprintf("%2d", iter),
257	!	": objective = ", sprintf("%11.9f", new.obj),
258	!	" alpha = ", sprintf("%6.5f", alpha),
259	!	" rms.x = ", sprintf("%9.9f", rms.x), "\n",
260	!	sep = ""
261		)
262		# print(new.x)
263		}
264
265		# check for convergence
266	!	if (rms.x < tol.x) {
267	!	old.x <- new.x
268	!	old.obj <- new.obj
269	!	if (lav_verbose()) {
270	!	cat("Gauss-Newton algorithm converged: rms.x = ",
271	!	sprintf("%12.12f", rms.x), " < ",
272	!	sprintf("%12.12f", tol.x), "\n",
273	!	sep = ""
274		)
275		}
276	!	break
277		} else {
278	!	old.x <- new.x
279	!	old.obj <- new.obj
280		}
281		} # iter
282
283	!	x <- new.x
284
285		# one last evaluation, to get fx.group attribute
286	!	lavmodel <- lav_model_set_parameters(lavmodel = lavmodel, x = x)
287	!	fx <- lav_model_objective(
288	!	lavmodel = lavmodel, lavdata = lavdata,
289	!	lavsamplestats = lavsamplestats
290		)
291
292		# add attributes
293	!	if (iter < iter.max) {
294	!	attr(x, "converged") <- TRUE
295	!	attr(x, "warn.txt") <- ""
296		} else {
297	!	attr(x, "converged") <- FALSE
298	!	attr(x, "warn.txt") <- paste("maxmimum number of iterations (",
299	!	iter.max, ") ",
300	!	"was reached without convergence.\n",
301	!	sep = ""
302		)
303		}
304	!	attr(x, "iterations") <- iter
305	!	attr(x, "control") <- list(
306	!	iter.max = iter.max,
307	!	tol.x = tol.x
308		)
309	!	attr(x, "fx") <- fx
310
311	!	x
312		}

1		# the weighted bivariate linear regression model
2		# YR 14 March 2020 ((replacing the old lav_pearson.R + lav_binorm.R routines)
3		#
4		# - bivariate standard normal
5		# - pearson correlation
6		# - bivariate linear regression
7		# - using sampling weights wt
8
9
10		# density of a bivariate __standard__ normal
11		lav_dbinorm <- lav_dbinorm <- function(u, v, rho, force.zero = FALSE) {
12		# dirty hack to handle extreme large values for rho
13		# note that u, v, and rho are vectorized!
14	296x	RHO.limit <- 0.9999
15	296x	abs.rho <- abs(rho)
16	296x	idx <- which(abs.rho > RHO.limit)
17	296x	if (length(idx) > 0L) {
18	!	rho[idx] <- sign(rho[idx]) * RHO.limit
19		}
20
21	296x	R <- 1 - rho * rho
22	296x	out <- 1 / (2 * pi * sqrt(R)) * exp(-0.5 * (u * u - 2 * rho * u * v + v * v) / R)
23
24		# if abs(u) or abs(v) are very large (say, >10), set result equal
25		# to exactly zero
26	296x	idx <- which(abs(u) > 10 \| abs(v) > 10)
27	296x	if (length(idx) > 0L && force.zero) {
28	!	out[idx] <- 0
29		}
30
31	296x	out
32		}
33
34		# partial derivative - rho
35		lav_dbinorm_drho <- function(u, v, rho) {
36	!	R <- 1 - rho * rho
37	!	lav_dbinorm(u, v, rho) * (u * v * R - rho * (u * u - 2 * rho * u * v + v * v) + rho * R) / (R * R)
38		}
39
40		# partial derivative - u
41		lav_dbinorm_du <- function(u, v, rho) {
42	!	R <- 1 - rho * rho
43	!	-lav_dbinorm(u, v, rho) * (u - rho * v) / R
44		}
45
46		# partial derivative - v
47		lav_dbinorm_dv <- function(u, v, rho) {
48	!	R <- 1 - rho * rho
49	!	-lav_dbinorm(u, v, rho) * (v - rho * u) / R
50		}
51
52
53		# CDF of bivariate standard normal
54		# function pbinorm(upper.x, upper.y, rho)
55
56		# partial derivative pbinorm - upper.x
57		lav_pbinorm_dupperx <- function(upper.x, upper.y, rho = 0.0) {
58	!	R <- 1 - rho * rho
59	!	dnorm(upper.x) * pnorm((upper.y - rho * upper.x) / sqrt(R))
60		}
61
62		lav_pbinorm_duppery <- function(upper.x, upper.y, rho = 0.0) {
63	!	R <- 1 - rho * rho
64	!	dnorm(upper.y) * pnorm((upper.x - rho * upper.y) / sqrt(R))
65		}
66
67		lav_pbinorm_drho <- function(upper.x, upper.y, rho = 0.0) {
68	!	lav_dbinorm(upper.x, upper.y, rho)
69		}
70
71
72		# switch between pbivnorm, mnormt, ...
73		pbinorm <- function(upper.x = NULL, upper.y = NULL, rho = 0.0,
74		lower.x = -Inf, lower.y = -Inf, check = FALSE) {
75	96x	pbinorm2(
76	96x	upper.x = upper.x, upper.y = upper.y, rho = rho,
77	96x	lower.x = lower.x, lower.y = lower.y, check = check
78		)
79		}
80
81		# using vectorized version (a la pbivnorm)
82		pbinorm2 <- function(upper.x = NULL, upper.y = NULL, rho = 0.0,
83		lower.x = -Inf, lower.y = -Inf, check = FALSE) {
84	96x	N <- length(upper.x)
85	96x	stopifnot(length(upper.y) == N)
86	96x	if (N > 1L) {
87	96x	if (length(rho) == 1L) {
88	96x	rho <- rep(rho, N)
89		}
90	96x	if (length(lower.x) == 1L) {
91	!	lower.x <- rep(lower.x, N)
92		}
93	96x	if (length(lower.y) == 1L) {
94	!	lower.y <- rep(lower.y, N)
95		}
96		}
97
98	96x	upper.only <- all(lower.x == -Inf & lower.y == -Inf)
99	96x	if (upper.only) {
100	!	upper.x[upper.x == +Inf] <- exp(10) # better pnorm?
101	!	upper.y[upper.y == +Inf] <- exp(10)
102	!	upper.x[upper.x == -Inf] <- -exp(10)
103	!	upper.y[upper.y == -Inf] <- -exp(10)
104	!	res <- pbivnorm(upper.x, upper.y, rho = rho)
105		} else {
106		# pbivnorm does not handle -Inf well...
107	96x	lower.x[lower.x == -Inf] <- -exp(10)
108	96x	lower.y[lower.y == -Inf] <- -exp(10)
109	96x	res <- pbivnorm(upper.x, upper.y, rho = rho) -
110	96x	pbivnorm(lower.x, upper.y, rho = rho) -
111	96x	pbivnorm(upper.x, lower.y, rho = rho) +
112	96x	pbivnorm(lower.x, lower.y, rho = rho)
113		}
114
115	96x	res
116		}
117
118
119
120		# pearson correlation
121		# if no missing, solution is just cor(Y1,Y2) or cor(e1,e2)
122		# but if missing, two-step solution is NOT the same as cor(Y1,Y2) or cor(e1,e2)
123		lav_bvreg_cor_twostep_fit <- function(Y1, Y2, eXo = NULL, wt = NULL,
124		fit.y1 = NULL, fit.y2 = NULL,
125		Y1.name = NULL, Y2.name = NULL,
126		optim.method = "nlminb1",
127		# optim.method = "none",
128		optim.scale = 1,
129		init.theta = NULL,
130		control = list()) {
131	90x	if (is.null(fit.y1)) {
132	!	fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt)
133		}
134	90x	if (is.null(fit.y2)) {
135	!	fit.y2 <- lav_uvreg_fit(y = Y2, X = eXo, wt = wt)
136		}
137
138		# create cache environment
139	90x	cache <- lav_bvreg_init_cache(fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt)
140
141		# the complete case is trivial
142	90x	if (!anyNA(fit.y1$y) && !anyNA(fit.y2$y)) {
143	!	return(cache$theta[1L])
144		}
145
146		# optim.method
147	90x	minObjective <- lav_bvreg_min_objective
148	90x	minGradient <- lav_bvreg_min_gradient
149	90x	minHessian <- lav_bvreg_min_hessian
150	90x	if (optim.method == "nlminb" \|\| optim.method == "nlminb2") {
151		# nothing to do
152	90x	} else if (optim.method == "nlminb0") {
153	!	minGradient <- minHessian <- NULL
154	90x	} else if (optim.method == "nlminb1") {
155	90x	minHessian <- NULL
156	!	} else if (optim.method == "none") {
157	!	return(cache$theta[1L])
158		}
159
160		# optimize
161	90x	if (is.null(control$trace)) {
162	90x	control$trace <- ifelse(lav_verbose(), 1, 0)
163		}
164
165		# init theta?
166	90x	if (!is.null(init.theta)) {
167	!	start.x <- init.theta
168		} else {
169	90x	start.x <- cache$theta
170		}
171
172		# try 1
173	90x	optim <- nlminb(
174	90x	start = start.x, objective = minObjective,
175	90x	gradient = minGradient, hessian = minHessian,
176	90x	control = control,
177	90x	scale = optim.scale, lower = -0.999, upper = +0.999,
178	90x	cache = cache
179		)
180
181		# try 2 (scale = 10)
182	90x	if (optim$convergence != 0L) {
183	2x	optim <- nlminb(
184	2x	start = start.x, objective = minObjective,
185	2x	gradient = minGradient, hessian = minHessian,
186	2x	control = control,
187	2x	scale = 10, lower = -0.999, upper = +0.999,
188	2x	cache = cache
189		)
190		}
191
192		# try 3 (start = 0, step.min = 0.1)
193	90x	if (optim$convergence != 0L) {
194	!	control$step.min <- 0.1
195	!	minGradient <- lav_bvreg_min_gradient
196		# try again, with different starting value
197	!	optim <- nlminb(
198	!	start = 0, objective = minObjective,
199	!	gradient = minGradient, hessian = NULL,
200	!	control = control,
201	!	scale = optim.scale, lower = -0.999, upper = +0.999,
202	!	cache = cache
203		)
204		}
205
206		# check convergence
207	90x	if (optim$convergence != 0L) {
208	!	if (!is.null(Y1.name) && !is.null(Y2.name)) {
209	!	lav_msg_warn(gettextf(
210	!	"estimation pearson correlation did not converge for variables %1$s
211	!	and %2$s.", Y1.name, Y2.name))
212		} else {
213	!	lav_msg_warn(gettext(
214	!	"estimation pearson correlation(s) did not always converge"))
215		}
216
217		# use init (as we always did in < 0.6-6; this is also what Mplus does)
218	!	rho <- start.x
219		} else {
220		# store result
221	90x	rho <- optim$par
222		}
223
224	90x	rho
225		}
226
227		# Y1 = linear
228		# Y2 = linear
229		lav_bvreg_init_cache <- function(fit.y1 = NULL,
230		fit.y2 = NULL,
231		wt = NULL,
232		scores = FALSE,
233		parent = parent.frame()) {
234		# data
235	180x	Y1 <- fit.y1$y
236	180x	Y2 <- fit.y2$y
237	180x	eXo <- fit.y1$X
238
239		# Y1
240	180x	Y1c <- Y1 - fit.y1$yhat
241	180x	evar.y1 <- fit.y1$theta[fit.y1$var.idx]
242	180x	sd.y1 <- sqrt(evar.y1)
243	180x	eta.y1 <- fit.y1$yhat
244
245		# Y2
246	180x	Y2c <- Y2 - fit.y2$yhat
247	180x	evar.y2 <- fit.y2$theta[fit.y1$var.idx]
248	180x	sd.y2 <- sqrt(evar.y2)
249	180x	eta.y2 <- fit.y2$yhat
250
251
252		# exo?
253	180x	if (is.null(eXo)) {
254	!	nexo <- 0L
255		} else {
256	180x	nexo <- ncol(eXo)
257		}
258
259		# nobs
260	180x	if (is.null(wt)) {
261	180x	N <- length(Y1)
262		} else {
263	!	N <- sum(wt)
264		}
265
266		# starting value
267	180x	if (fit.y1$nexo > 0L) {
268	180x	E1 <- Y1 - fit.y1$yhat
269	180x	E2 <- Y2 - fit.y2$yhat
270	180x	if (is.null(wt)) {
271	180x	rho.init <- cor(E1, E2, use = "pairwise.complete.obs")
272		} else {
273	!	tmp <- na.omit(cbind(E1, E2, wt))
274	!	rho.init <- cov.wt(tmp[, 1:2], wt = tmp[, 3], cor = TRUE)$cor[2, 1]
275		}
276		} else {
277	!	if (is.null(wt)) {
278	!	rho.init <- cor(Y1, Y2, use = "pairwise.complete.obs")
279		} else {
280	!	tmp <- na.omit(cbind(Y1, Y2, wt))
281	!	rho.init <- cov.wt(tmp[, 1:2], wt = tmp[, 3], cor = TRUE)$cor[2, 1]
282		}
283		}
284
285		# sanity check
286	180x	if (is.na(rho.init) \|\| abs(rho.init) >= 1.0) {
287	!	rho.init <- 0.0
288		}
289
290		# parameter vector
291	180x	theta <- rho.init # only
292
293		# different cache if scores or not
294	180x	if (scores) {
295	90x	out <- list2env(
296	90x	list(
297	90x	nexo = nexo, theta = theta, N = N,
298	90x	Y1c = Y1c, Y2c = Y2c, eXo = eXo,
299	90x	evar.y1 = evar.y1, sd.y1 = sd.y1, eta.y1 = eta.y1,
300	90x	evar.y2 = evar.y2, sd.y2 = sd.y2, eta.y2 = eta.y2
301		),
302	90x	parent = parent
303		)
304		} else {
305	90x	out <- list2env(
306	90x	list(
307	90x	nexo = nexo, theta = theta, N = N,
308	90x	Y1c = Y1c, Y2c = Y2c,
309	90x	evar.y1 = evar.y1, sd.y1 = sd.y1, eta.y1 = eta.y1,
310	90x	evar.y2 = evar.y2, sd.y2 = sd.y2, eta.y2 = eta.y2
311		),
312	90x	parent = parent
313		)
314		}
315
316	180x	out
317		}
318
319
320		# casewise likelihoods, unweighted!
321		lav_bvreg_lik_cache <- function(cache = NULL) {
322	708x	with(cache, {
323	708x	rho <- theta[1L]
324
325	708x	cov.y12 <- rho * sqrt(evar.y1) * sqrt(evar.y2)
326	708x	sigma <- matrix(c(evar.y1, cov.y12, cov.y12, evar.y2), 2L, 2L)
327	708x	lik <- exp(lav_mvnorm_loglik_data(
328	708x	Y = cbind(Y1c, Y2c), wt = NULL,
329	708x	Mu = c(0, 0), Sigma = sigma,
330	708x	casewise = TRUE
331		))
332		# catch very small values
333	708x	lik.toosmall.idx <- which(lik < sqrt(.Machine$double.eps))
334	708x	lik[lik.toosmall.idx] <- as.numeric(NA)
335
336	708x	return(lik)
337		})
338		}
339
340		lav_bvreg_logl_cache <- function(cache = NULL) {
341	708x	with(cache, {
342	708x	lik <- lav_bvreg_lik_cache(cache) # unweighted!
343
344	708x	if (!is.null(wt)) {
345	!	logl <- sum(wt * log(lik), na.rm = TRUE)
346		} else {
347	708x	logl <- sum(log(lik), na.rm = TRUE)
348		}
349
350	708x	return(logl)
351		})
352		}
353
354		lav_bvreg_gradient_cache <- function(cache = NULL) {
355	460x	with(cache, {
356	460x	rho <- theta[1L]
357	460x	R <- (1 - rho * rho)
358
359	460x	sd.y1.y2 <- sd.y1 * sd.y2
360	460x	t1 <- (Y1c * Y2c) / sd.y1.y2
361	460x	t2 <- (Y1c * Y1c) / evar.y1 - (2 * rho * t1) + (Y2c * Y2c) / evar.y2
362	460x	dx <- (rho + t1 - t2 * rho / R) / R
363
364		# to be consistent with (log)lik_cache
365	460x	if (length(lik.toosmall.idx) > 0L) {
366	238x	dx[lik.toosmall.idx] <- as.numeric(NA)
367		}
368
369	460x	if (is.null(wt)) {
370	460x	dx.rho <- sum(dx, na.rm = TRUE)
371		} else {
372	!	dx.rho <- sum(wt * dx, na.rm = TRUE)
373		}
374
375	460x	return(dx.rho)
376		})
377		}
378
379		lav_bvreg_hessian_cache <- function(cache = NULL) {
380	!	with(cache, {
381	!	rho <- theta[1L]
382
383	!	rho2 <- rho * rho
384	!	R2 <- R * R
385	!	R3 <- R * R * R
386
387	!	h <- 1 / R - (2 * rho2 * t2) / R3 + 2 * rho2 * (1 - t2 / R) / R2 + 4 * rho * t1 / R2 - t2 / R2
388
389		# to be consistent with (log)lik_cache
390	!	if (length(lik.toosmall.idx) > 0L) {
391	!	h[lik.toosmall.idx] <- as.numeric(NA)
392		}
393
394	!	if (is.null(wt)) {
395	!	H <- sum(h, na.rm = TRUE)
396		} else {
397	!	H <- sum(wt * h, na.rm = TRUE)
398		}
399	!	dim(H) <- c(1L, 1L) # for nlminb
400
401	!	return(H)
402		})
403		}
404
405		# compute total (log)likelihood, for specific 'x' (nlminb)
406		lav_bvreg_min_objective <- function(x, cache = NULL) {
407	674x	cache$theta <- x
408	674x	-1 * lav_bvreg_logl_cache(cache = cache) / cache$N
409		}
410
411		# compute gradient, for specific 'x' (nlminb)
412		lav_bvreg_min_gradient <- function(x, cache = NULL) {
413		# check if x has changed
414	460x	if (!all(x == cache$theta)) {
415	34x	cache$theta <- x
416	34x	tmp <- lav_bvreg_logl_cache(cache = cache)
417		}
418	460x	-1 * lav_bvreg_gradient_cache(cache = cache) / cache$N
419		}
420
421		# compute hessian, for specific 'x' (nlminb)
422		lav_bvreg_min_hessian <- function(x, cache = NULL) {
423		# check if x has changed
424	!	if (!all(x == cache$theta)) {
425	!	tmp <- lav_bvreg_logl_cache(cache = cache)
426	!	tmp <- lav_bvreg_gradient_cache(cache = cache)
427		}
428	!	-1 * lav_bvreg_hessian_cache(cache = cache) / cache$N
429		}
430
431		# casewise scores - cache
432		# FIXME: should we also set 'lik.toosmall.idx' cases to NA?
433		lav_bvreg_cor_scores_cache <- function(cache = NULL) {
434	90x	with(cache, {
435	90x	rho <- theta[1L]
436	90x	R <- (1 - rho * rho)
437
438		# mu.y1
439	90x	dx.mu.y1 <- (2 * Y1c / evar.y1 - 2 * rho * Y2c / (sd.y1 * sd.y2)) / (2 * R)
440	90x	if (!is.null(wt)) {
441	!	dx.mu.y1 <- wt * dx.mu.y1
442		}
443
444		# mu.y2
445	90x	dx.mu.y2 <- -(2 * rho * Y1c / (sd.y1 * sd.y2) - 2 * Y2c / evar.y2) / (2 * R)
446	90x	if (!is.null(wt)) {
447	!	dx.mu.y2 <- wt * dx.mu.y2
448		}
449
450		# evar.y1
451	90x	dx.var.y1 <- -(0.5 / evar.y1 - ((Y1c * Y1c) / (evar.y1 * evar.y1) -
452	90x	rho * Y1c * Y2c / (evar.y1 * sd.y1 * sd.y2)) / (2 * R))
453	90x	if (!is.null(wt)) {
454	!	dx.var.y1 <- wt * dx.var.y1
455		}
456
457		# var.y2
458	90x	dx.var.y2 <- -(0.5 / evar.y2 + (rho * Y1c * Y2c / (evar.y2 * sd.y1 * sd.y2) -
459	90x	(Y2c * Y2c) / (evar.y2 * evar.y2)) / (2 * R))
460	90x	if (!is.null(wt)) {
461	!	dx.var.y2 <- wt * dx.var.y2
462		}
463
464		# sl.y1
465	90x	dx.sl.y1 <- NULL
466	90x	if (nexo > 0L) {
467	90x	dx.sl.y1 <- dx.mu.y1 * eXo # weights already included in dx.mu.y1
468		}
469
470		# sl.y2
471	90x	dx.sl.y2 <- NULL
472	90x	if (nexo > 0L) {
473	90x	dx.sl.y2 <- dx.mu.y2 * eXo # weights already included in dx.mu.y2
474		}
475
476		# rho
477	90x	z <- (Y1c * Y1c) / evar.y1 - 2 * rho * Y1c * Y2c / (sd.y1 * sd.y2) + (Y2c * Y2c) / evar.y2
478	90x	dx.rho <- rho / R + (Y1c * Y2c / (sd.y1 * sd.y2 * R) - z * rho / (R * R))
479	90x	if (!is.null(wt)) {
480	!	dx.rho <- wt * dx.rho
481		}
482
483	90x	out <- list(
484	90x	dx.mu.y1 = dx.mu.y1, dx.var.y1 = dx.var.y1,
485	90x	dx.mu.y2 = dx.mu.y2, dx.var.y2 = dx.var.y2,
486	90x	dx.sl.y1 = dx.sl.y1, dx.sl.y2 = dx.sl.y2,
487	90x	dx.rho = dx.rho
488		)
489	90x	return(out)
490		})
491		}
492
493		# casewise scores
494		#
495		# Y1 = linear
496		# Y2 = linear
497		lav_bvreg_cor_scores <- function(Y1, Y2, eXo = NULL, wt = NULL,
498		rho = NULL,
499		fit.y1 = NULL, fit.y2 = NULL,
500		evar.y1 = NULL, beta.y1 = NULL,
501		evar.y2 = NULL, beta.y2 = NULL) {
502	90x	if (is.null(fit.y1)) {
503	!	fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt)
504		}
505	90x	if (is.null(fit.y2)) {
506	!	fit.y2 <- lav_uvreg_fit(y = Y2, X = eXo, wt = wt)
507		}
508
509		# user specified parameters
510	90x	if (!is.null(evar.y1) \|\| !is.null(beta.y1)) {
511	!	fit.y1 <- lav_uvreg_update_fit(
512	!	fit.y = fit.y1,
513	!	evar.new = evar.y1, beta.new = beta.y1
514		)
515		}
516	90x	if (!is.null(evar.y2) \|\| !is.null(beta.y2)) {
517	!	fit.y2 <- lav_uvreg_update_fit(
518	!	fit.y = fit.y2,
519	!	evar.new = evar.y2, beta.new = beta.y2
520		)
521		}
522
523		# create cache environment
524	90x	cache <- lav_bvreg_init_cache(
525	90x	fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt,
526	90x	scores = TRUE
527		)
528	90x	cache$theta <- rho
529
530	90x	SC <- lav_bvreg_cor_scores_cache(cache = cache)
531
532	90x	SC
533		}
534
535		# logl - no cache
536		lav_bvreg_logl <- function(Y1, Y2, eXo = NULL, wt = NULL,
537		rho = NULL,
538		fit.y1 = NULL, fit.y2 = NULL,
539		evar.y1 = NULL, beta.y1 = NULL,
540		evar.y2 = NULL, beta.y2 = NULL) {
541	!	if (is.null(fit.y1)) {
542	!	fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt)
543		}
544	!	if (is.null(fit.y2)) {
545	!	fit.y2 <- lav_uvreg_fit(y = Y2, X = eXo, wt = wt)
546		}
547
548		# user specified parameters
549	!	if (!is.null(evar.y1) \|\| !is.null(beta.y1)) {
550	!	fit.y1 <- lav_uvreg_update_fit(
551	!	fit.y = fit.y1,
552	!	evar.new = evar.y1, beta.new = beta.y1
553		)
554		}
555	!	if (!is.null(evar.y2) \|\| !is.null(beta.y2)) {
556	!	fit.y2 <- lav_uvreg_update_fit(
557	!	fit.y = fit.y2,
558	!	evar.new = evar.y2, beta.new = beta.y2
559		)
560		}
561
562		# create cache environment
563	!	cache <- lav_bvreg_init_cache(
564	!	fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt,
565	!	scores = TRUE
566		)
567	!	cache$theta <- rho
568
569	!	lav_bvreg_logl_cache(cache = cache)
570		}
571
572		# lik - no cache
573		lav_bvreg_lik <- function(Y1, Y2, eXo = NULL, wt = NULL,
574		rho = NULL,
575		fit.y1 = NULL, fit.y2 = NULL,
576		evar.y1 = NULL, beta.y1 = NULL,
577		evar.y2 = NULL, beta.y2 = NULL,
578		.log = FALSE) {
579	!	if (is.null(fit.y1)) {
580	!	fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt)
581		}
582	!	if (is.null(fit.y2)) {
583	!	fit.y2 <- lav_uvreg_fit(y = Y2, X = eXo, wt = wt)
584		}
585
586		# user specified parameters
587	!	if (!is.null(evar.y1) \|\| !is.null(beta.y1)) {
588	!	fit.y1 <- lav_uvreg_update_fit(
589	!	fit.y = fit.y1,
590	!	evar.new = evar.y1, beta.new = beta.y1
591		)
592		}
593	!	if (!is.null(evar.y2) \|\| !is.null(beta.y2)) {
594	!	fit.y2 <- lav_uvreg_update_fit(
595	!	fit.y = fit.y2,
596	!	evar.new = evar.y2, beta.new = beta.y2
597		)
598		}
599
600		# create cache environment
601	!	cache <- lav_bvreg_init_cache(
602	!	fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt,
603	!	scores = TRUE
604		)
605	!	cache$theta <- rho
606
607	!	lik <- lav_bvreg_lik_cache(cache = cache)
608	!	if (.log) {
609	!	lik <- log(lik)
610		}
611
612	!	if (!is.null(wt)) {
613	!	if (.log) {
614	!	lik <- wt * lik
615		} else {
616	!	tmp <- wt * log(lik)
617	!	lik <- exp(tmp)
618		}
619		}
620
621	!	lik
622		}

1		# the entries of the lavaan and lavaanList objects have changed over time
2		# this function will check if the lavaan/lavaanList object is up to date, and
3		# adapt, if not.
4		#
5		# this may be useful if an older (say 0.5) lavaan object was saved, and
6		# passed to a function like lavPredict() in, say, lavaan 0.6-21.
7
8		# notes:
9		# - pre<0.5 lavaan objects are no longer supported
10		# - @Fit slot is ignored (as not used anymore)
11
12		# YR 16 Oct 2025 + LDW 22 Oct 2025
13
14		lav_object_check_version <- function(object = NULL) {
15
16	1824x	is.lavaan.object <- inherits(object, "lavaan")
17	1824x	if (!is.lavaan.object) {
18		# check if lavaanList object, if not return input object
19	!	if (!inherits(object, "lavaanList")) return(object)
20		}
21
22		# flag: check or not?
23	1824x	check_not_needed_flag <- TRUE
24
25		# do we have a version slot?
26	1824x	if (.hasSlot(object, "version")) {
27	1824x	has_version_flag <- TRUE
28	1824x	lavobject_version <- object@version[1] # lavaan.mi has two
29	1824x	lavaanpkg_version <- read.dcf(
30	1824x	file = system.file("DESCRIPTION", package = "lavaan"),
31	1824x	fields = "Version"
32	1824x	)[1]
33	1824x	if (lavobject_version != lavaanpkg_version) {
34	!	check_not_needed_flag <- FALSE
35		}
36		} else {
37		# <0.6
38	!	has_version_flag <- FALSE
39	!	check_not_needed_flag <- FALSE
40		}
41
42		# check needed?
43	1824x	if (check_not_needed_flag) {
44	1824x	return(object)
45		}
46
47		# ok, we have potentially an older (saved) lavaan or lavaanList object
48		# check needed slots, and if missing, add them
49	!	suppressWarnings(lavobject <- object)
50	!	ngroups <- lav_partable_ngroups(lavobject@ParTable)
51	!	nblocks <- lav_partable_nblocks(lavobject@ParTable)
52	!	nlevels <- lav_partable_nlevels(lavobject@ParTable)
53
54	!	if (!has_version_flag) { # pre 0.6 object!
55		# 0.5-10 (25 Oct 2012)
56	!	if (!.hasSlot(lavobject@Data, "group")) {
57	!	lavobject@Data@group <- character(0L)
58		}
59
60		# 0.5-11 (19 dec 2012)
61	!	if (is.lavaan.object) {
62	!	if (!.hasSlot(lavobject@SampleStats, "bifreq")) {
63	!	lavobject@SampleStats@bifreq <- vector("list", length = ngroups)
64		}
65	!	if (!.hasSlot(lavobject, "Cache")) {
66	!	lavobject@Cache <- list()
67		}
68		}
69
70		# 0.5-12 (8 March 2013)
71	!	if (is.lavaan.object) {
72	!	if (!.hasSlot(lavobject@SampleStats, "ridge")) {
73	!	lavobject@SampleStats@ridge <- 0
74		}
75		}
76
77		# 0.5-14 (21 July 2013)
78	!	if (is.lavaan.object) {
79	!	if (!.hasSlot(lavobject@Model, "ov.x.dummy.ov.idx")) {
80	!	lavobject@Model@ov.x.dummy.ov.idx <- vector("list", length = nblocks)
81	!	lavobject@Model@ov.x.dummy.lv.idx <- vector("list", length = nblocks)
82	!	lavobject@Model@ov.y.dummy.ov.idx <- vector("list", length = nblocks)
83	!	lavobject@Model@ov.y.dummy.lv.idx <- vector("list", length = nblocks)
84		}
85	!	if (!.hasSlot(lavobject@SampleStats, "mean.x")) {
86	!	lavobject@SampleStats@mean.x <- vector("list", length = ngroups)
87	!	for (g in seq_len(ngroups)) {
88	!	if (!is.null(lavobject@SampleStats@x.idx[[g]])) {
89	!	lavobject@SampleStats@mean.x[[g]] <-
90	!	lavobject@SampleStats@mean[[g]][lavobject@SampleStats@x.idx[[g]]]
91		}
92		}
93		}
94	!	if (!.hasSlot(lavobject, "pta")) {
95	!	lavobject@pta <- list()
96		}
97		}
98
99		# 0.5-15 (15 Nov 2013)
100	!	if (is.lavaan.object) {
101	!	if (!.hasSlot(lavobject@Data, "Rp")) {
102	!	lavobject@Data@Rp <- vector("list", length = ngroups)
103		}
104		}
105
106		# 0.5-16 (7 March 2014)
107	!	if (is.lavaan.object) {
108	!	if (!.hasSlot(lavobject@SampleStats, "group.w")) {
109	!	lavobject@SampleStats@group.w <- vector("list", length = ngroups)
110	!	for (g in seq_len(ngroups)) {
111	!	lavobject@SampleStats@group.w[[g]] <-
112	!	lavobject@SampleStats@nobs[[g]] / lavobject@SampleStats@ntotal
113		}
114		}
115	!	if (!.hasSlot(lavobject@Model, "group.w.free")) {
116	!	lavobject@Model@group.w.free <- FALSE
117		}
118	!	if (!.hasSlot(lavobject@Model, "parameterization")) {
119	!	lavobject@Model@parameterization <- "delta"
120		}
121	!	if (!.hasSlot(lavobject@Model, "link")) {
122	!	lavobject@Model@link <- "default"
123		}
124		}
125
126		# 0.5-17 (30 Sept 2014)
127	!	if (is.lavaan.object) {
128	!	if (!.hasSlot(lavobject@SampleStats, "WLS.VD")) {
129	!	lavobject@SampleStats@WLS.VD <- vector("list", length = ngroups)
130		}
131		}
132
133		# 0.5-18 (18 Nov 2014)
134	!	if (is.lavaan.object) {
135	!	if (!.hasSlot(lavobject@Model, "eq.constraints.k0")) {
136	!	lavobject@Model@eq.constraints.k0 <- numeric(0L)
137		}
138	!	if (!.hasSlot(lavobject@Model, "ceq.linear.idx")) {
139	!	lavobject@Model@ceq.linear.idx <- integer(0L)
140	!	lavobject@Model@ceq.nonlinear.idx <- integer(0L)
141	!	lavobject@Model@cin.linear.idx <- integer(0L)
142	!	lavobject@Model@cin.nonlinear.idx <- integer(0L)
143		}
144		}
145
146		# 0.5-18 (13 Jan 2015)
147	!	if (is.lavaan.object) {
148	!	if (!.hasSlot(lavobject@Model, "ceq.JAC")) {
149	!	lavobject@Model@ceq.JAC <- matrix(0, nrow = 0L,
150	!	ncol = lavobject@Model@nx.free)
151	!	lavobject@Model@ceq.rhs <- numeric(0L)
152	!	lavobject@Model@cin.JAC <- matrix(0, nrow = 0L,
153	!	ncol = lavobject@Model@nx.free)
154	!	lavobject@Model@cin.rhs <- numeric(0L)
155		}
156		}
157
158		# 0.5-19 (30 Jul 2015)
159	!	if (is.lavaan.object) {
160	!	if (!.hasSlot(lavobject, "boot")) {
161		# construct partial optim list
162	!	optim_list <- list(x = lavobject@Fit@x,
163	!	dx = numeric(0L),
164	!	npar = lavobject@Fit@npar,
165	!	iterations = lavobject@Fit@iterations,
166	!	converged = lavobject@Fit@converged,
167	!	warn.txt = "",
168	!	parscale = rep(1, lavobject@Fit@npar),
169	!	fx = lavobject@Fit@fx,
170	!	fx.group = lavobject@Fit@fx.group,
171	!	logl.group = lavobject@Fit@logl.group,
172	!	control = lavobject@Fit@control)
173	!	lavobject@boot <- vector("list", 0L)
174	!	lavobject@optim <- optim_list
175	!	lavobject@implied <- lav_model_implied(lavobject@Model)
176	!	lavobject@vcov <- list(se = lavobject@Options$se[1],
177	!	information = lavobject@Options$information[1],
178	!	vcov = matrix(0, 0, 0)) # for now
179	!	lavobject@test <- lavTest(lavobject)
180	!	lavobject@external <- vector("list", 0L)
181		}
182		}
183
184		# 0.5-19: est/se move to @ParTable
185	!	if (!is.null(lavobject@Fit@est) && is.null(lavobject@ParTable$est)) {
186	!	lavobject@ParTable$est <- lavobject@Fit@est
187		}
188	!	if (!is.null(lavobject@Fit@se) && is.null(lavobject@ParTable$se)) {
189	!	lavobject@ParTable$se <- lavobject@Fit@se
190		}
191
192
193		# 0.5-21 (16 Dec 2015)
194	!	if (is.lavaan.object) {
195	!	if (!.hasSlot(lavobject@Model, "conditional.x")) {
196	!	lavobject@Model@conditional.x <- FALSE
197		}
198		}
199
200		# 0.5-21 (5 Jan 2016)
201	!	if (is.lavaan.object) {
202	!	if (!.hasSlot(lavobject@SampleStats, "x.idx")) {
203	!	lavobject@SampleStats@x.idx <- rep(list(integer(0L)), ngroups)
204		}
205		}
206
207		# 0.5-21 (8 Jan 2016)
208	!	if (is.lavaan.object) {
209	!	if (!.hasSlot(lavobject@SampleStats, "res.cov")) {
210	!	lavobject@SampleStats@res.cov <- vector("list", ngroups)
211	!	lavobject@SampleStats@res.var <- vector("list", ngroups)
212	!	lavobject@SampleStats@res.th <- vector("list", ngroups)
213	!	lavobject@SampleStats@res.th.nox <- vector("list", ngroups)
214	!	lavobject@SampleStats@res.slopes <- vector("list", ngroups)
215	!	lavobject@SampleStats@res.int <- vector("list", ngroups)
216	!	lavobject@SampleStats@res.icov <- vector("list", ngroups)
217	!	lavobject@SampleStats@res.icov.log.det <- vector("list", ngroups)
218		}
219		}
220
221		# 0.5-21 (28 Mar 2016)
222	!	if (is.lavaan.object) {
223	!	if (!.hasSlot(lavobject@SampleStats, "NACOV.user")) {
224	!	lavobject@SampleStats@NACOV.user <- FALSE
225		}
226		}
227
228		#### 0.5-21, 3 Jul 2016, Class lavaanList is added ####
229
230		# 0.5-23 (25 Jan 2017)
231	!	if (!.hasSlot(lavobject@Model, "estimator")) {
232	!	lavobject@Model@estimator <- lavobject@Options$estimator
233		}
234
235		# 0.5-23 (30 Jan 2017)
236	!	if (is.lavaan.object) {
237	!	if (!.hasSlot(lavobject@Data, "cluster")) {
238	!	lavobject@Data@cluster <- character(0L)
239	!	lavobject@Data@ordered <- character(0L)
240		}
241		} else {
242	!	for (j in seq_along(lavobject@DataList)) {
243	!	if (!.hasSlot(lavobject@DataList[[j]], "cluster")) {
244	!	lavobject@DataList[[j]]@cluster <- character(0L)
245	!	lavobject@DataList[[j]]@ordered <- character(0L)
246		}
247		}
248		}
249
250		# 0.5-23 (7 Feb 2017)
251	!	if (is.lavaan.object) {
252	!	if (!.hasSlot(lavobject@SampleStats, "zero.cell.tables")) {
253	!	lavobject@SampleStats@zero.cell.tables <- vector("list", ngroups)
254		}
255		} else {
256	!	for (j in seq_along(lavobject@SampleStatsList)) {
257	!	if (!.hasSlot(lavobject@SampleStatsList[[j]], "zero.cell.tables")) {
258	!	lavobject@SampleStatsList[[j]]@zero.cell.tables <- vector("list", ngroups)
259		}
260		}
261		}
262
263		# 0.5-23 (21 Feb 2017)
264	!	if (!.hasSlot(lavobject@Model, "nblocks")) {
265	!	lavobject@Model@nblocks <- nblocks
266		}
267	!	if (is.lavaan.object) {
268	!	if (!.hasSlot(lavobject@Data, "level.label")) {
269	!	lavobject@Data@level.label <- as.character(seq.int(nlevels))
270		}
271		} else {
272	!	for (j in seq_along(lavobject@DataList)) {
273	!	if (!.hasSlot(lavobject@DataList[[j]], "level.label")) {
274	!	lavobject@DataList[[j]]@level.label <- as.character(seq.int(nlevels))
275		}
276		}
277		}
278	!	if (is.lavaan.object) {
279	!	if (!.hasSlot(lavobject@Data, "block.label")) {
280	!	if (nlevels <= 1L) {
281	!	if (ngroups <= 1L) {
282	!	lavobject@Data@block.label <- character(0L)
283		} else {
284	!	lavobject@Data@block.label <- lavobject@Data@group.label
285		}
286		} else {
287	!	if (ngroups <= 1L) {
288	!	lavobject@Data@block.label <- lavobject@Data@level.label
289		} else {
290	!	lavobject@Data@block.label <-
291	!	paste(rep(lavobject@Data@group.label,
292	!	each = length(lavobject@Data@level.label)),
293	!	rep(lavobject@Data@level.label,
294	!	times = length(lavobject@Data@group.label)),
295	!	sep = "."
296		)
297		}
298		}
299		}
300		} else {
301	!	for (j in seq_along(lavobject@DataList)) {
302	!	if (!.hasSlot(lavobject@DataList[[j]], "block.label")) {
303	!	if (nlevels <= 1L) {
304	!	if (ngroups <= 1L) {
305	!	lavobject@DataList[[j]]@block.label <- character(0L)
306		} else {
307	!	lavobject@DataList[[j]]@block.label <-
308	!	lavobject@DataList[[j]]@group.label
309		}
310		} else {
311	!	if (ngroups <= 1L) {
312	!	lavobject@DataList[[j]]@block.label <-
313	!	lavobject@DataList[[j]]@level.label
314		} else {
315	!	lavobject@DataList[[j]]@block.label <-
316	!	paste(rep(lavobject@DataList[[j]]@group.label,
317	!	each = length(lavobject@DataList[[j]]@level.label)),
318	!	rep(lavobject@DataList[[j]]@level.label,
319	!	times = length(lavobject@DataList[[j]]@group.label)),
320	!	sep = "."
321		)
322		}
323		}
324		}
325		}
326		}
327
328		# 0.5-23 (24 Feb 2017)
329	!	if (is.lavaan.object) {
330	!	if (!.hasSlot(lavobject@Data, "nlevels")) {
331	!	lavobject@Data@nlevels <- nlevels
332	!	lavobject@Data@Lp <- vector("list", ngroups)
333		}
334		} else {
335	!	for (j in seq_along(lavobject@DataList)) {
336	!	if (!.hasSlot(lavobject@DataList[[j]], "nlevels")) {
337	!	lavobject@DataList[[j]]@nlevels <- nlevels
338	!	lavobject@DataList[[j]]@Lp <- vector("list", ngroups)
339		}
340		}
341		}
342	!	if (is.lavaan.object) {
343	!	if (!.hasSlot(lavobject@SampleStats, "YLp")) {
344	!	lavobject@SampleStats@YLp <- vector("list", ngroups)
345		}
346		} else {
347	!	for (j in seq_along(lavobject@SampleStatsList)) {
348	!	if (!.hasSlot(lavobject@SampleStatsList[[j]], "YLp")) {
349	!	lavobject@SampleStatsList[[j]]@YLp <- vector("list", ngroups)
350		}
351		}
352		}
353
354		# 0.6-1 (8 Mar 2017)
355	!	if (is.lavaan.object) {
356	!	if (!.hasSlot(lavobject, "h1")) {
357	!	lavobject@h1 <- lav_h1_implied_logl(lavdata = lavobject@Data,
358	!	lavsamplestats = lavobject@SampleStats,
359	!	lavpartable = lavobject@ParTable,
360	!	lavoptions = lavobject@Options)
361	!	lavobject@baseline <- lav_lavaan_step15_baseline(
362	!	lavoptions = lavobject@Options,
363	!	lavsamplestats = lavobject@SampleStats,
364	!	lavdata = lavobject@Data,
365	!	lavcache = lavobject@Cache,
366	!	lavpartable = lavobject@ParTable
367		)
368		}
369	!	if (!.hasSlot(lavobject@Data, "ov.names.l")) {
370	!	lavobject@Data@ov.names.l <- vector("list", 0L)
371		}
372		} else {
373	!	for (j in seq_along(lavobject@DataList)) {
374	!	if (!.hasSlot(lavobject@DataList[[j]], "ov.names.l")) {
375	!	lavobject@DataList[[j]]@ov.names.l <- vector("list", 0L)
376		}
377		}
378		}
379
380		# 0.6-1 (10 Mar 2017)
381	!	if (!.hasSlot(lavobject@Model, "multilevel")) {
382	!	lavobject@Model@multilevel <- FALSE
383		}
384
385		# 0.6-1 (19 Mar 2017)
386	!	if (is.lavaan.object) {
387	!	if (!.hasSlot(lavobject, "loglik")) {
388	!	lavobject@Model@ceq.simple.only <- FALSE
389	!	lavobject@Model@cin.simple.only <- FALSE
390	!	lavobject@loglik <- lav_model_loglik(
391	!	lavdata = lavobject@Data,
392	!	lavsamplestats = lavobject@SampleStats,
393	!	lavimplied = lavobject@implied,
394	!	lavmodel = lavobject@Model,
395	!	lavoptions = lavobject@Options
396		)
397		}
398		}
399
400		# 0.6-1 (1 Oct 2017)
401	!	if (is.lavaan.object) {
402	!	if (!.hasSlot(lavobject@Data, "weights")) {
403	!	lavobject@Data@weights <- vector("list", ngroups)
404		}
405		} else {
406	!	for (j in seq_along(lavobject@DataList)) {
407	!	if (!.hasSlot(lavobject@DataList[[j]], "weights")) {
408	!	lavobject@DataList[[j]]@weights <- vector("list", ngroups)
409		}
410		}
411		}
412
413		# 0.6-1 (3 Oct 2017)
414	!	if (is.lavaan.object) {
415	!	if (!.hasSlot(lavobject@Data, "sampling.weights")) {
416	!	lavobject@Data@sampling.weights <- character(0L)
417		}
418		} else {
419	!	for (j in seq_along(lavobject@DataList)) {
420	!	if (!.hasSlot(lavobject@DataList[[j]], "sampling.weights")) {
421	!	lavobject@DataList[[j]]@sampling.weights <- character(0L)
422		}
423		}
424		}
425
426		# 0.6-1 (2 May 2018)
427	!	if (is.lavaan.object) {
428	!	if (!.hasSlot(lavobject, "version")) lavobject@version <- "PRE 0.6"
429		}
430		} # no-version-flag (pre 0.6)
431
432		### from here on, we assume that the object is generated by lavaan 0.6-1 or
433		### higher
434
435		# check if @test list is named
436	!	if (is.null(names(lavobject@test))) {
437	!	names(lavobject@test) <- sapply(lavobject@test, "[[", "test")
438		}
439
440		# 0.6-2 (12 Jun 2018)
441	!	if (!.hasSlot(lavobject@Model, "x.free.var.idx")) {
442	!	lavobject@Model@x.free.var.idx <- integer(0L)
443		}
444
445		# 0.6-3 (17 Sep 2018)
446	!	if (!is.lavaan.object) {
447	!	if (!.hasSlot(lavobject, "h1List")) {
448	!	lavobject@h1List <- vector("list", 0L)
449	!	lavobject@loglikList <- vector("list", 0L)
450		}
451		}
452
453		# 0.6-4 (30 Mar 2019)
454	!	if (!.hasSlot(lavobject@Model, "ov.efa.idx")) {
455	!	lavobject@Model@ov.efa.idx <- vector("list", nblocks)
456	!	lavobject@Model@lv.efa.idx <- vector("list", nblocks)
457		}
458
459		# 0.6-4 (11 Apr 2019)
460	!	if (!.hasSlot(lavobject@Model, "nefa")) {
461	!	lavobject@Model@nefa <- 0L
462		}
463
464		# 0.6-4 (24 Apr 2019)
465	!	if (!.hasSlot(lavobject@Model, "H")) {
466	!	lavobject@Model@H <- vector("list", 0L)
467	!	lavobject@Model@lv.order <- vector("list", 0L)
468		}
469
470		# 0.6-4 (26 Apr 2019)
471	!	if (!.hasSlot(lavobject@Model, "ceq.efa.JAC")) {
472	!	lavobject@Model@ceq.efa.JAC <- matrix(0, nrow = 0L, ncol = 0L)
473		}
474
475		# 0.6-5 (7 Jul 2019)
476	!	if (!is.lavaan.object) {
477	!	if (!.hasSlot(lavobject, "baselineList")) {
478	!	lavobject@baselineList <- vector("list", 0L)
479		}
480		}
481
482		# 0.6-8 (29 Sep 2020)
483	!	if (!.hasSlot(lavobject@Model, "rv.ov")) {
484	!	lavobject@Model@rv.ov <- vector("list", 0L)
485	!	lavobject@Model@rv.lv <- vector("list", 0L)
486		}
487
488		# 0.6-8 (18 Dec 2020)
489	!	if (!.hasSlot(lavobject@Model, "estimator.args")) {
490	!	lavobject@Model@estimator.args <- vector("list", 0L)
491		}
492
493		# 0.6-9 (15 Mar 2021)
494	!	if (!.hasSlot(lavobject@Model, "modprop")) {
495	!	lavobject@Model@modprop = lav_model_properties(
496	!	GLIST = lavobject@Model@GLIST,
497	!	lavpartable = lavobject@ParTable,
498	!	nmat = lavobject@Model@nmat,
499	!	m.free.idx = lavobject@Model@m.free.idx
500		)
501		}
502
503		# 0.6-9 (22 Jun 2021)
504	!	if (is.lavaan.object) {
505	!	if (!.hasSlot(lavobject, "internal")) {
506	!	lavobject@internal <- vector("list", 0L)
507		}
508		} else {
509	!	if (!.hasSlot(lavobject, "internalList")) {
510	!	lavobject@internalList <- vector("list", 0L)
511		}
512		}
513
514		# 0.6-11 (28 Feb 2022)
515	!	if (!.hasSlot(lavobject@Model, "nx.unco")) {
516		# is not available, unco == free
517	!	lavobject@Model@nx.unco <- lavobject@Model@nx.free
518	!	lavobject@Model@x.unco.idx <- lavobject@Model@x.free.idx
519	!	lavobject@Model@ceq.simple.only <- FALSE
520	!	lavobject@Model@ceq.simple.K <- matrix(0, nrow = 0L, ncol = 0L)
521		}
522
523		# 0.6-13 (25 Jul 2022)
524	!	if (!.hasSlot(lavobject@Model, "correlation")) {
525	!	lavobject@Model@correlation <- FALSE
526		}
527
528		# 0.6-18 (25 Apr 2024)
529	!	if (!is.lavaan.object) {
530	!	if (!.hasSlot(lavobject, "version")) {
531	!	lavobject@version <- "PRE 0.6.18"
532		}
533		}
534
535		# 0.6-19 (27 Sep 2024)
536	!	if (!.hasSlot(lavobject@Model, "cin.simple.only")) {
537	!	lavobject@Model@cin.simple.only <- FALSE
538		}
539
540		# 0.6-20 (24 Jan 2025)
541	!	if (!.hasSlot(lavobject@Model, "composites")) {
542	!	lavobject@Model@composites <- any(lavobject@ParTable$op == "<~")
543		}
544
545		# check missing options
546	!	object_options <- lavobject@Options
547	!	all_options <- lavOptions()
548	!	missing.idx <- which(!names(all_options) %in% names(object_options))
549	!	new_options <- c(object_options, all_options[missing.idx])
550		# fill in some "default" values
551	!	if (new_options$estimator.orig == "default") {
552	!	new_options$estimator.orig <- new_options$estimator
553		}
554
555		# 0.6-21
556	!	new_options$gamma.vcov.mplus <- new_options$mimic == "Mplus"
557	!	new_options$gamma.wls.mplus <- new_options$mimic == "Mplus"
558	!	new_options$gls.v11.mplus <- new_options$mimic == "Mplus"
559	!	new_options$cinformation.expected.mplus <- new_options$mimic == "Mplus"
560	!	new_options$h1.information.meat <- "structured"
561	!	new_options$mega.h1.information <- "unstructured"
562
563		# 0.6-22
564	!	if (is.null(new_options$rotation.args$mg.agreement)) {
565	!	new_options$rotation.args$mg.agreement <- FALSE
566	!	new_options$rotation.args$mg.agreement.weight <- 0.5
567	!	new_options$rotation.args$mg.agreement.method <- "pairwise"
568	!	ew_options$rotation.args$mg.agreement.crit <- "procrustes"
569
570		}
571	!	if (is.null(new_options$rotation.args$mg.agreement.weight)) {
572	!	new_options$rotation.args$mg.agreement.weight <- 0.5
573		}
574
575	!	lavobject@Options <- new_options
576
577	!	lavobject
578		}

1		# RAM representation
2		#
3		# initial version: YR 2021-10-04
4
5		lav_ram <- function(partable = NULL,
6		target = NULL,
7		extra = FALSE,
8		remove.nonexisting = TRUE) {
9		# prepare target list
10	!	if (is.null(target)) target <- partable
11
12	!	stopifnot(!is.null(target$block))
13
14		# not for categorical data (yet)
15	!	if (any(partable$op == "\|")) {
16	!	lav_msg_stop(gettext("RAM representation is not (yet) supported for
17	!	categorical endogenous variables."))
18		}
19
20		# not for conditional.x = TRUE yet
21	!	conditional.x <- any(partable$exo > 0L & partable$op == "~")
22	!	if (conditional.x) {
23	!	lav_msg_stop(gettext("RAM representation is not (yet) supported
24	!	if conditional.x = TRUE"))
25		}
26
27		# prepare output
28	!	N <- length(target$lhs)
29	!	tmp.mat <- character(N)
30	!	tmp.row <- integer(N)
31	!	tmp.col <- integer(N)
32
33		# global settings
34	!	meanstructure <- any(partable$op == "~1")
35	!	categorical <- any(partable$op == "\|")
36	!	group.w.free <- any(partable$lhs == "group" & partable$op == "%")
37
38		# number of blocks
39	!	nblocks <- lav_partable_nblocks(partable)
40
41		# always return ov.idx
42	!	ov.idx <- vector("list", nblocks)
43	!	ov.dummy.names.nox <- vector("list", nblocks)
44	!	ov.dummy.names.x <- vector("list", nblocks)
45	!	if (extra) {
46	!	REP.mmNames <- vector("list", nblocks)
47	!	REP.mmNumber <- vector("list", nblocks)
48	!	REP.mmRows <- vector("list", nblocks)
49	!	REP.mmCols <- vector("list", nblocks)
50	!	REP.mmDimNames <- vector("list", nblocks)
51	!	REP.mmSymmetric <- vector("list", nblocks)
52		}
53
54	!	for (g in 1:nblocks) {
55		# info from user model per block
56	!	ov.names <- lav_partable_vnames(partable, "ov", block = g)
57	!	nvar <- length(ov.names)
58	!	ov.idx[[g]] <- seq_len(nvar)
59	!	ov.dummy.names.nox[[g]] <- character(0)
60	!	ov.dummy.names.x[[g]] <- character(0)
61
62	!	lv.names <- lav_partable_vnames(partable, "lv", block = g)
63	!	both.names <- c(ov.names, lv.names)
64	!	nboth <- length(both.names)
65
66		# 1. "=~" indicators
67	!	idx <- which(target$block == g & target$op == "=~")
68	!	tmp.mat[idx] <- "A"
69	!	tmp.row[idx] <- match(target$rhs[idx], both.names)
70	!	tmp.col[idx] <- match(target$lhs[idx], both.names)
71
72		# 2. "~" regressions
73	!	idx <- which(target$block == g & (target$op == "~" \|
74	!	target$op == "<~"))
75	!	tmp.mat[idx] <- "A"
76	!	tmp.row[idx] <- match(target$lhs[idx], both.names)
77	!	tmp.col[idx] <- match(target$rhs[idx], both.names)
78
79		# 3. "~~" variances/covariances
80	!	idx <- which(target$block == g & target$op == "~~")
81	!	tmp.mat[idx] <- "S"
82	!	tmp.row[idx] <- match(target$lhs[idx], both.names)
83	!	tmp.col[idx] <- match(target$rhs[idx], both.names)
84
85		# catch lower-elements in theta/psi
86	!	idx.lower <- which(tmp.mat == "S" & tmp.row > tmp.col)
87	!	if (length(idx.lower) > 0L) {
88	!	tmp <- tmp.row[idx.lower]
89	!	tmp.row[idx.lower] <- tmp.col[idx.lower]
90	!	tmp.col[idx.lower] <- tmp
91		}
92
93		# 4. "~1" means/intercepts
94	!	idx <- which(target$block == g & target$op == "~1")
95	!	tmp.mat[idx] <- "m"
96	!	tmp.row[idx] <- match(target$lhs[idx], both.names)
97	!	tmp.col[idx] <- 1L
98
99		# 5. "\|" th
100		# not used yet
101
102		# 6. "~*~" scales
103		# not used yet
104
105		# 7. group weights
106	!	idx <- which(target$block == g & target$lhs == "group" &
107	!	target$op == "%")
108	!	tmp.mat[idx] <- "gw"
109	!	tmp.row[idx] <- 1L
110	!	tmp.col[idx] <- 1L
111
112	!	if (extra) {
113		# mRows
114	!	mmRows <- list(
115	!	ov.idx = 1L,
116	!	A = nboth,
117	!	S = nboth,
118	!	m = nboth,
119	!	gw = 1L
120		)
121
122		# mCols
123	!	mmCols <- list(
124	!	ov.idx = nvar,
125	!	A = nboth,
126	!	S = nboth,
127	!	m = 1L,
128	!	gw = 1L
129		)
130
131		# dimNames for LISREL model matrices
132	!	mmDimNames <- list(
133	!	ov.idx = list("ov.idx", ov.names),
134	!	A = list(both.names, both.names),
135	!	S = list(both.names, both.names),
136	!	m = list(both.names, "intercept"),
137	!	gw = list("group", "weight")
138		)
139		# isSymmetric
140	!	mmSymmetric <- list(
141	!	ov.idx = FALSE,
142	!	A = FALSE,
143	!	S = TRUE,
144	!	m = FALSE,
145	!	gw = FALSE
146		)
147
148		# which mm's do we need? (always include ov.idx, A and S)
149	!	IDX <- which(target$block == g)
150	!	mmNames <- c("ov.idx", "A", "S")
151	!	if (meanstructure) {
152	!	mmNames <- c(mmNames, "m")
153		}
154	!	if ("gw" %in% tmp.mat[IDX]) {
155	!	mmNames <- c(mmNames, "gw")
156		}
157
158	!	REP.mmNames[[g]] <- mmNames
159	!	REP.mmNumber[[g]] <- length(mmNames)
160	!	REP.mmRows[[g]] <- unlist(mmRows[mmNames])
161	!	REP.mmCols[[g]] <- unlist(mmCols[mmNames])
162	!	REP.mmDimNames[[g]] <- mmDimNames[mmNames]
163	!	REP.mmSymmetric[[g]] <- unlist(mmSymmetric[mmNames])
164		} # extra
165		} # nblocks
166
167	!	REP <- list(
168	!	mat = tmp.mat,
169	!	row = tmp.row,
170	!	col = tmp.col
171		)
172
173		# always return ov.idx attribute
174	!	attr(REP, "ov.idx") <- ov.idx
175	!	attr(REP, "ov.dummy.names.nox") <- ov.dummy.names.nox
176	!	attr(REP, "ov.dummy.names.x") <- ov.dummy.names.x
177
178	!	if (extra) {
179	!	attr(REP, "mmNames") <- REP.mmNames
180	!	attr(REP, "mmNumber") <- REP.mmNumber
181	!	attr(REP, "mmRows") <- REP.mmRows
182	!	attr(REP, "mmCols") <- REP.mmCols
183	!	attr(REP, "mmDimNames") <- REP.mmDimNames
184	!	attr(REP, "mmSymmetric") <- REP.mmSymmetric
185		}
186
187	!	REP
188		}
189
190		# the model-implied variance/covariance matrix of the observed variables
191		lav_ram_sigmahat <- function(MLIST = NULL, delta = NULL) {
192	!	ov.idx <- as.integer(MLIST$ov.idx[1, ])
193	!	A <- MLIST$A
194	!	S <- MLIST$S
195
196		# get (I-A)^{-1}
197	!	IA.inv <- lav_matrix_inverse_iminus(A)
198
199		# compute Sigma for all ov and lv
200	!	VYeta <- tcrossprod(IA.inv %*% S, IA.inv)
201
202		# select only observed part
203	!	VY <- VYeta[ov.idx, ov.idx, drop = FALSE]
204
205		# if delta, scale
206	!	if (!is.null(MLIST$delta) && delta) {
207	!	nvar <- ncol(VY)
208	!	DELTA <- diag(MLIST$delta[, 1L], nrow = nvar, ncol = nvar)
209	!	VY <- DELTA %% VY %% DELTA
210		}
211
212	!	VY
213		}
214
215		# VETA: the variance/covariance matrix of the latent variables only
216		lav_ram_veta <- function(MLIST = NULL) {
217	!	ov.idx <- as.integer(MLIST$ov.idx[1, ])
218	!	A <- MLIST$A
219	!	S <- MLIST$S
220
221		# get (I-A)^{-1}
222	!	IA.inv <- lav_matrix_inverse_iminus(A)
223
224		# compute Sigma for all ov and lv
225	!	VYeta <- tcrossprod(IA.inv %*% S, IA.inv)
226
227		# select only latent part
228	!	VETA <- VYeta[-ov.idx, -ov.idx, drop = FALSE]
229
230	!	VETA
231		}
232
233		# MuHat: the model-implied means/intercepts
234		lav_ram_muhat <- function(MLIST = NULL) {
235	!	ov.idx <- as.integer(MLIST$ov.idx[1, ])
236	!	A <- MLIST$A
237	!	m <- MLIST$m
238
239		# shortcut
240	!	if (is.null(m)) {
241	!	return(matrix(0, nrow = length(ov.idx), 1L))
242		}
243
244		# get (I-A)^{-1}
245	!	IA.inv <- lav_matrix_inverse_iminus(A)
246
247		# all means/intercepts
248	!	EYeta <- IA.inv %*% m
249
250		# select observed only
251	!	muhat <- EYeta[ov.idx, , drop = FALSE]
252
253	!	muhat
254		}
255
256		# derivative of 'Sigma' wrt the (freel) elements in A and/or S
257		lav_ram_dsigma <- function(m = "A",
258		idx = seq_len(length(MLIST[[m]])),
259		MLIST = NULL,
260		vech = TRUE) {
261	!	ov.idx <- as.integer(MLIST$ov.idx[1, ])
262	!	A <- MLIST$A
263	!	S <- MLIST$S
264
265	!	nvar <- length(ov.idx)
266	!	nboth <- nrow(A)
267
268		# shortcut for ov.idx, m, ...
269	!	if (!m %in% c("A", "S")) {
270	!	pstar <- nvar * (nvar + 1) / 2
271	!	return(matrix(0.0, nrow = pstar, ncol = length(idx)))
272		}
273
274		# get (I-A)^{-1}
275	!	IA.inv <- lav_matrix_inverse_iminus(A)
276
277	!	if (m == "A") {
278	!	L1 <- (IA.inv %% S %% t(IA.inv))[ov.idx, , drop = FALSE]
279	!	KOL.idx <- matrix(1:(nboth * nboth), nboth, nboth, byrow = TRUE)[idx]
280	!	DX <- (L1 %x% IA.inv[ov.idx, , drop = FALSE])[, idx, drop = FALSE] +
281	!	(IA.inv[ov.idx, , drop = FALSE] %x% L1)[, KOL.idx, drop = FALSE]
282		# this is not really needed (because we select idx=m.el.idx)
283		# but just in case we need all elements of beta...
284	!	DX[, which(idx %in% lav_matrix_diag_idx(nboth))] <- 0.0
285	!	} else if (m == "S") {
286	!	DX <- (IA.inv[ov.idx, , drop = FALSE] %x% IA.inv[ov.idx, , drop = FALSE])
287		# symmetry correction, but keeping all duplicated elements
288		# since we depend on idx=m.el.idx
289	!	lower.idx <- lav_matrix_vech_idx(nboth, diagonal = FALSE)
290	!	upper.idx <- lav_matrix_vechru_idx(nboth, diagonal = FALSE)
291	!	offdiagSum <- DX[, lower.idx] + DX[, upper.idx]
292	!	DX[, c(lower.idx, upper.idx)] <- cbind(offdiagSum, offdiagSum)
293	!	DX <- DX[, idx, drop = FALSE]
294		} else {
295	!	lav_msg_stop(gettext("wrong model matrix names:"), m)
296		}
297
298		# vech?
299	!	if (vech) {
300	!	v.idx <- lav_matrix_vech_idx(nvar)
301	!	DX <- DX[v.idx, , drop = FALSE]
302		}
303
304	!	DX
305		}
306
307		# derivative of 'Mu' wrt the (free) elements in A and/or m
308		lav_ram_dmu <- function(m = "A",
309		idx = seq_len(length(MLIST[[m]])),
310		MLIST = NULL,
311		vech = TRUE) {
312	!	ov.idx <- as.integer(MLIST$ov.idx[1, ])
313	!	A <- MLIST$A
314	!	S <- MLIST$S
315
316	!	nvar <- length(ov.idx)
317	!	nboth <- nrow(A)
318
319		# shortcut for ov.idx, m, ...
320	!	if (!m %in% c("A", "m")) {
321	!	return(matrix(0.0, nrow = nvar, ncol = length(idx)))
322		}
323
324		# get (I-A)^{-1}
325	!	IA.inv <- lav_matrix_inverse_iminus(A)
326
327	!	if (m == "A") {
328	!	DX <- (t(IA.inv %*% MLIST$m) %x% IA.inv)[ov.idx, idx, drop = FALSE]
329	!	} else if (m == "m") {
330	!	DX <- IA.inv[ov.idx, idx, drop = FALSE]
331		} else {
332	!	lav_msg_stop(gettext("wrong model matrix names:"), m)
333		}
334
335	!	DX
336		}
337
338		# derivative of ML/GLS objective function F wrt the free parameters
339		lav_ram_df <- function(MLIST = NULL, Omega = NULL, Omega.mu = NULL) {
340	!	ov.idx <- as.integer(MLIST$ov.idx[1, ])
341	!	A <- MLIST$A
342	!	S <- MLIST$S
343
344	!	nvar <- length(ov.idx)
345	!	nboth <- nrow(A)
346
347		# get (I-A)^{-1}
348	!	IA.inv <- lav_matrix_inverse_iminus(A)
349
350		# meanstructure?
351	!	meanstructure <- FALSE
352	!	if (!is.null(Omega.mu)) meanstructure <- TRUE
353
354		# pre-compute
355	!	tIA.inv <- t(IA.inv)
356	!	Omega..IA.inv..S..tIA.inv <- (Omega %% IA.inv[ov.idx, , drop = FALSE] %% S %*% t(IA.inv))
357
358		# 1. A
359	!	if (meanstructure) {
360	!	A.deriv <-
361	!	-1.0 * ((t(IA.inv)[, ov.idx, drop = FALSE] %% (Omega.mu %% t(MLIST$m)) %*% t(IA.inv)) +
362	!	(tIA.inv[, ov.idx, drop = FALSE] %*% Omega..IA.inv..S..tIA.inv))
363		} else {
364	!	A.deriv <- -1.0 * (tIA.inv[, ov.idx, drop = FALSE] %*% Omega..IA.inv..S..tIA.inv)
365		}
366
367		# 2. S
368	!	S.deriv <- -1.0 * (tIA.inv[, ov.idx, drop = FALSE] %% Omega %% IA.inv[ov.idx, , drop = FALSE])
369	!	diag(S.deriv) <- 0.5 * diag(S.deriv)
370
371	!	if (meanstructure) {
372	!	m.deriv <- -1.0 * t(t(Omega.mu) %*% IA.inv[ov.idx, , drop = FALSE])
373		} else {
374	!	m.deriv <- NULL
375		}
376
377	!	list(
378	!	A = A.deriv,
379	!	S = S.deriv,
380	!	m = m.deriv
381		)
382		}

1		# Factor extraction method(s)
2		# YR Feb 2020
3		#
4		# - ULS_corner only (for now)
5		# - just to get better starting values for ESEM
6
7		# YR July 2020
8		# - adding generic function lav_efa_extraction, using eigenvalue based
9		# approach; ML and ULS
10		# - 'corner' is an option
11
12		lav_efa_extraction <- function(S, nfactors = 1L,
13		method = "ULS", # or ML
14		corner = FALSE,
15		reflect = FALSE, order.lv.by = "none",
16		min.var = 0.0001) {
17	4x	stopifnot(is.matrix(S))
18	4x	S <- unname(S)
19	4x	method <- tolower(method)
20
21		# extract variances
22	4x	S.var <- diag(S)
23
24		# force S to be pd (eg if we have polychoric correlations)
25	4x	S <- lav_matrix_symmetric_force_pd(S, tol = 1e-08)
26
27		# convert to correlation matrix (ULS is not scale invariant!)
28	4x	R <- cov2cor(S)
29
30		# optim.method
31	4x	if (method == "uls") {
32	!	minObjective <- lav_efa_uls_min_objective
33	!	minGradient <- lav_efa_uls_min_gradient
34	!	cache <- lav_efa_uls_init_cache(R = R, nfactors = nfactors)
35	4x	} else if (method == "ml") {
36	4x	minObjective <- lav_efa_ml_min_objective
37	4x	minGradient <- lav_efa_ml_min_gradient
38	4x	cache <- lav_efa_ml_init_cache(R = R, nfactors = nfactors)
39		} else {
40	!	lav_msg_stop(gettext("method must be uls or ml (for now)"))
41		}
42	4x	minHessian <- NULL
43
44		# optimize
45	4x	control.nlminb <- list(
46	4x	eval.max = 20000L, iter.max = 10000L,
47	4x	trace = if (lav_verbose()) {
48	!	1L
49		} else {
50	4x	0L
51		},
52	4x	abs.tol = (.Machine$double.eps * 10)
53		)
54	4x	if (lav_verbose()) {
55	!	cat("\n")
56	!	cat("factor extraction iterations using ", method, ":\n")
57		}
58	4x	out <- nlminb(
59	4x	start = cache$theta, objective = minObjective,
60	4x	gradient = minGradient, hessian = minHessian,
61	4x	control = control.nlminb, lower = min.var, upper = +1,
62	4x	cache = cache
63		)
64
65		# extract LAMBDA/THETA
66	4x	if (method == "uls") {
67	!	THETA <- diag(out$par * out$par)
68
69		# compute LAMBDA
70	!	A <- R
71	!	diag(A) <- diag(A) - (out$par * out$par)
72	!	EV <- eigen(A, symmetric = TRUE)
73	!	Omega.1 <- EV$vectors[, 1:nfactors]
74	!	gamma.1 <- EV$values[1:nfactors]
75
76		# LAMBDA <- Omega.1 %*% diag(sqrt(gamma.1))
77	!	LAMBDA <- t(t(Omega.1) * sqrt(gamma.1))
78
79		# rescale if the input matrix was not a correlation matrix
80	!	LAMBDA <- sqrt(S.var) * LAMBDA
81	!	diag(THETA) <- S.var * diag(THETA)
82	4x	} else if (method == "ml") {
83	4x	THETA <- diag(out$par * out$par)
84
85		# compute LAMBDA
86	4x	psi <- out$par
87	4x	A <- t(psi * cache$R.inv) * psi
88	4x	EV <- eigen(A, symmetric = TRUE)
89	4x	Omega.1 <- EV$vectors[, 1L + cache$nvar - seq_len(cache$nfactors),
90	4x	drop = FALSE
91		]
92	4x	gamma.1 <- EV$values[1L + cache$nvar - seq_len(cache$nfactors)]
93
94		# LAMBDA <- diag(psi) %% Omega.1 %%sqrt(solve(Gamma.1)-diag(nfactors))
95	4x	tmp1 <- psi * Omega.1
96	4x	LAMBDA <- t(t(tmp1) * sqrt((1 / gamma.1) - 1))
97
98		# rescale if the input matrix was not a correlation matrix
99	4x	LAMBDA <- sqrt(S.var) * LAMBDA
100	4x	diag(THETA) <- S.var * diag(THETA)
101		}
102
103		# corner?
104	4x	if (corner) {
105		# rotate to echelon pattern (see echelon() in GPArotation package)
106	4x	HEAD <- LAMBDA[seq_len(nfactors), , drop = FALSE]
107	4x	POST <- try(solve(HEAD, t(chol(tcrossprod(HEAD)))), silent = TRUE)
108	4x	okflag <- FALSE
109	4x	if (inherits(POST, "try-error")) { # new in 0.6-18
110		# this will happen if we have identical elements in the columns
111		# of HEAD (perhaps the data is artificial?)
112		# -> add some fuzz and try again
113	!	SD <- sqrt(mean(abs(HEAD))) * 1e-04
114	!	fuzz <- matrix(rnorm(nfactors * nfactors, 0, SD), nfactors, nfactors)
115	!	HEAD2 <- HEAD + fuzz
116	!	POST <- try(solve(HEAD2, t(chol(tcrossprod(HEAD2)))), silent = TRUE)
117	!	if (!inherits(POST, "try-error")) {
118	!	okflag <- TRUE
119		}
120		} else {
121	4x	okflag <- TRUE
122		}
123	4x	if (okflag) {
124	4x	LAMBDA <- LAMBDA %*% POST
125		} else {
126	!	lav_msg_warn(gettext(
127	!	"rotation of initial factor solution to echelon pattern failed."))
128		}
129		}
130
131		# ALWAYS change the sign so that largest element in the column is positive
132		# neg.max <- apply(LAMBDA, 2, function(x) { sign(x[which.max(abs(x))]) })
133		# neg.idx <- which(neg.max < 0)
134		# if(length(neg.idx) > 0L) {
135		# LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE]
136		# }
137
138		# ALWAYS change the sign so that diag(LAMBDA) is positive
139	4x	neg.idx <- which(diag(LAMBDA) < 0)
140	4x	if (length(neg.idx) > 0L) {
141	!	LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE]
142		}
143
144		# reflect so that column sum is always positive
145	4x	if (reflect) {
146	!	SUM <- colSums(LAMBDA)
147	!	neg.idx <- which(SUM < 0)
148	!	if (length(neg.idx) > 0L) {
149	!	LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE]
150		}
151		}
152
153		# reorder the columns
154	4x	if (order.lv.by == "sumofsquares") {
155	!	L2 <- LAMBDA * LAMBDA
156	!	order.idx <- base::order(colSums(L2), decreasing = TRUE)
157	4x	} else if (order.lv.by == "index") {
158		# reorder using Asparouhov & Muthen 2009 criterion (see Appendix D)
159	!	max.loading <- apply(abs(LAMBDA), 2, max)
160		# 1: per factor, number of the loadings that are at least 0.8 of the
161		# highest loading of the factor
162		# 2: mean of the index numbers
163	!	average.index <- sapply(seq_len(ncol(LAMBDA)), function(i) {
164	!	mean(which(abs(LAMBDA[, i]) >= 0.8 * max.loading[i]))
165		})
166		# order of the factors
167	!	order.idx <- base::order(average.index)
168	4x	} else if (order.lv.by == "none") {
169	4x	order.idx <- seq_len(ncol(LAMBDA))
170		} else {
171	!	lav_msg_stop(gettext("order must be index, sumofsquares or none"))
172		}
173	4x	LAMBDA <- LAMBDA[, order.idx, drop = FALSE]
174
175	4x	list(LAMBDA = LAMBDA, THETA = THETA)
176		}
177
178
179
180		lav_efa_uls_init_cache <- function(R = NULL,
181		nfactors = 1L,
182		parent = parent.frame()) {
183	!	R.inv <- solve(R)
184	!	nvar <- ncol(R)
185
186		# starting values for diagonal elements of THETA
187		# using Joreskog (1966) suggestion:
188	!	theta.init <- (1 - nfactors / (2 * nvar)) * 1 / diag(R.inv)
189	!	theta <- sqrt(theta.init)
190
191	!	out <- list2env(
192	!	list(
193	!	R = R, nfactors = nfactors,
194	!	theta = theta
195		),
196	!	parent = parent
197		)
198	!	out
199		}
200
201		# x is here the sqrt() of theta!
202		lav_efa_uls_min_objective <- function(x, cache = NULL) {
203	!	cache$theta <- x
204	!	with(cache, {
205	!	A <- R
206	!	diag(A) <- diag(A) - (theta * theta)
207	!	EV <- eigen(A, symmetric = TRUE, only.values = TRUE)
208	!	gamma.2 <- EV$values[-seq_len(nfactors)]
209
210	!	res <- 0.5 * sum(gamma.2 * gamma.2)
211	!	return(res)
212		})
213		}
214
215		lav_efa_uls_min_gradient <- function(x, cache = NULL) {
216		# check if x has changed
217	!	if (!all(x == cache$theta)) {
218	!	cache$theta <- x
219		# nothing to do
220		}
221	!	with(cache, {
222	!	A <- R
223	!	diag(A) <- diag(A) - (theta * theta)
224	!	EV <- eigen(A, symmetric = TRUE)
225	!	Omega.2 <- EV$vectors[, -seq_len(nfactors)]
226	!	gamma.2 <- EV$values[-seq_len(nfactors)]
227
228	!	res <- -2 * theta * colSums(t(Omega.2 * Omega.2) * gamma.2)
229	!	return(res)
230		})
231		}
232
233
234		# ML
235		lav_efa_ml_init_cache <- function(R = NULL,
236		nfactors = 1L,
237		parent = parent.frame()) {
238	4x	R.inv <- solve(R)
239	4x	nvar <- ncol(R)
240
241		# starting values for diagonal elements of THETA
242		# using Joreskog (1966) suggestion:
243	4x	theta.init <- (1 - nfactors / (2 * nvar)) * 1 / diag(R.inv)
244	4x	theta <- sqrt(theta.init)
245
246	4x	out <- list2env(
247	4x	list(
248	4x	R = R, nfactors = nfactors, R.inv = R.inv,
249	4x	nvar = nvar, # for ML only
250	4x	theta = theta
251		),
252	4x	parent = parent
253		)
254	4x	out
255		}
256
257
258		# x is here the sqrt of theta
259		lav_efa_ml_min_objective <- function(x, cache = NULL) {
260	73x	cache$theta <- x
261	73x	with(cache, {
262	73x	psi <- theta
263		# A <- diag(psi) %% R.inv %% diag(psi)
264	73x	A <- t(R.inv * psi) * psi
265	73x	EV <- eigen(A, symmetric = TRUE, only.values = TRUE)
266	73x	gamma.2 <- EV$values[(nvar - nfactors):1L]
267
268	73x	res <- sum(log(gamma.2) + 1 / gamma.2 - 1)
269	73x	return(res)
270		})
271		}
272
273		lav_efa_ml_min_gradient <- function(x, cache = NULL) {
274		# check if x has changed
275	57x	if (!all(x == cache$theta)) {
276	1x	cache$theta <- x
277		# nothing to do
278		}
279	57x	with(cache, {
280	57x	psi <- theta
281		# A <- diag(psi) %% solve(S) %% diag(psi)
282	57x	A <- t(R.inv * psi) * psi
283	57x	EV <- eigen(A, symmetric = TRUE)
284
285	57x	omega.2 <- EV$vectors[, (nvar - nfactors):1L, drop = FALSE]
286	57x	gamma.2 <- EV$values[(nvar - nfactors):1L]
287
288	57x	res <- colSums(t(omega.2 * omega.2) * (1 - 1 / gamma.2))
289	57x	return(res)
290		})
291		}
292
293
294
295
296		# ULS estimation
297		#
298		# - but resulting in a upper-corner all zeroes LAMBDA matrix
299		# - not using eigenvalues/vectors, but minimizing the residuals
300		# directly
301
302		# - should give the same results as MINRES (after an orthogonal transformation)
303		# - unless there are heywood cases; this function allows for negative variances!
304
305		lav_efa_extraction_uls_corner <- function(S, nfactors = 1L, reflect = TRUE,
306		order.lv.by = "none") {
307	!	stopifnot(is.matrix(S))
308	!	S <- unname(S)
309	!	nvar <- nrow(S)
310
311		# extract variances
312	!	S.var <- diag(S)
313
314		# convert to correlation matrix (ULS is not scale invariant!)
315	!	R <- cov2cor(S)
316		# R.inv <- solve(R)
317
318		# eigenvalue decomposition (to get starting values for LAMBDA)
319	!	EV <- eigen(R, symmetric = TRUE)
320
321		# extract first nfac components (assuming no measurement error)
322	!	PC <- (EV$vectors[, seq_len(nfactors), drop = FALSE] %*%
323	!	diag(sqrt(EV$values[seq_len(nfactors)])))
324
325		# rotate to echelon pattern (see echelon() in GPArotation package)
326	!	HEAD <- PC[seq_len(nfactors), , drop = FALSE]
327	!	LAMBDA <- PC %*% solve(HEAD, t(chol(tcrossprod(HEAD))))
328
329	!	THETA <- diag(nvar)
330	!	if (nfactors > 1L) {
331	!	corner.idx <- which(row(LAMBDA) < nfactors & col(LAMBDA) > row(LAMBDA))
332	!	lambda.idx <- seq_len(nvar * nfactors)[-corner.idx]
333	!	LAMBDA[corner.idx] <- 0 # to make them exactly zero
334		} else {
335	!	corner.idx <- integer(0L)
336	!	lambda.idx <- seq_len(nvar)
337		}
338
339		# optim.method
340	!	minObjective <- lav_efa_uls_corner_min_objective
341	!	minGradient <- lav_efa_uls_corner_min_gradient
342	!	minHessian <- NULL
343
344		# create cache environment
345	!	cache <- lav_efa_uls_corner_init_cache(
346	!	LAMBDA = LAMBDA,
347	!	lambda.idx = lambda.idx, R = R
348		)
349
350	!	control.nlminb <- list(
351	!	eval.max = 20000L, iter.max = 10000L,
352	!	trace = if (lav_verbose()) {
353	!	1L
354		} else {
355	!	0L
356		},
357	!	abs.tol = (.Machine$double.eps * 10)
358		)
359
360		# optimize
361	!	out <- nlminb(
362	!	start = cache$theta, objective = minObjective,
363	!	gradient = minGradient, hessian = minHessian,
364	!	control = control.nlminb, lower = -1, upper = +1,
365	!	cache = cache
366		)
367
368	!	LAMBDA[lambda.idx] <- out$par
369	!	diag(THETA) <- 1 - diag(tcrossprod(LAMBDA))
370
371		# rescale if the input matrix was not a correlation matrix
372	!	LAMBDA <- sqrt(S.var) * LAMBDA
373	!	diag(THETA) <- S.var * diag(THETA)
374
375		# reflect so that column sum is always positive
376	!	if (reflect) {
377	!	SUM <- colSums(LAMBDA)
378	!	neg.idx <- which(SUM < 0)
379	!	if (length(neg.idx) > 0L) {
380	!	LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE]
381		}
382		}
383
384		# reorder the columns
385	!	if (order.lv.by == "sumofsquares") {
386	!	L2 <- LAMBDA * LAMBDA
387	!	order.idx <- base::order(colSums(L2), decreasing = TRUE)
388	!	} else if (order.lv.by == "index") {
389		# reorder using Asparouhov & Muthen 2009 criterion (see Appendix D)
390	!	max.loading <- apply(abs(LAMBDA), 2, max)
391		# 1: per factor, number of the loadings that are at least 0.8 of the
392		# highest loading of the factor
393		# 2: mean of the index numbers
394	!	average.index <- sapply(seq_len(ncol(LAMBDA)), function(i) {
395	!	mean(which(abs(LAMBDA[, i]) >= 0.8 * max.loading[i]))
396		})
397		# order of the factors
398	!	order.idx <- base::order(average.index)
399	!	} else if (order.lv.by == "none") {
400	!	order.idx <- seq_len(ncol(LAMBDA))
401		} else {
402	!	lav_msg_stop(gettext("order must be index, sumofsquares or none"))
403		}
404	!	LAMBDA <- LAMBDA[, order.idx, drop = FALSE]
405
406	!	list(LAMBDA = LAMBDA, THETA = THETA)
407		}
408
409
410		lav_efa_uls_corner_init_cache <- function(LAMBDA = NULL,
411		lambda.idx = NULL,
412		R = NULL,
413		parent = parent.frame()) {
414	!	theta <- LAMBDA[lambda.idx]
415	!	out <- list2env(
416	!	list(
417	!	LAMBDA = LAMBDA,
418	!	lambda.idx = lambda.idx,
419	!	R = R,
420	!	theta = theta
421		),
422	!	parent = parent
423		)
424	!	out
425		}
426
427		lav_efa_uls_corner_min_objective <- function(x, cache = NULL) {
428	!	cache$theta <- x
429	!	with(cache, {
430	!	LAMBDA[lambda.idx] <- theta
431	!	res1 <- lav_matrix_vech(R - tcrossprod(LAMBDA), diagonal = FALSE)
432	!	res2 <- res1 * res1
433	!	return(sum(res2))
434		})
435		}
436
437		lav_efa_uls_corner_min_gradient <- function(x, cache = NULL) {
438		# check if x has changed
439	!	if (!all(x == cache$theta)) {
440	!	cache$theta <- x
441		# nothing to do
442		}
443	!	with(cache, {
444	!	LAMBDA[lambda.idx] <- theta
445	!	Sigma <- tcrossprod(LAMBDA)
446	!	diag(Sigma) <- 1 # diagonal is ignored
447	!	tmp <- -2 * (R - Sigma) %*% LAMBDA
448	!	return(tmp[lambda.idx])
449		})
450		}